home *** CD-ROM | disk | FTP | other *** search
/ HAM Radio 1997 / HAM Radio 1997.iso / vcls / imagelib.001 / tdbmulti.pas < prev    next >
Pascal/Delphi Source File  |  1996-04-08  |  84KB  |  2,767 lines
  1. {Copyright 1995 by
  2.  Kevin Adams, 74742,1444
  3.  Jan Dekkers, 72130,353
  4.  
  5. No part of this Unit may be copied in any way.
  6. However, you may derive other objects from
  7. TDBMultiImage and/or TDBMultiMedia.
  8.  
  9. Part of Imagelib VCL/DLL Library.
  10.  
  11. Written by Jan Dekkers and Kevin Adams}
  12.  
  13. unit TDBMulti;
  14.  
  15. interface
  16.  
  17. uses
  18.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Forms,
  19.   Controls, Extctrls, StdCtrls, DLL22LIN, Menus, DB, DBTables, Mask,
  20.   Buttons, MPlayer, SetSrMsg, Printers;
  21.  
  22.  
  23.  
  24. { TDBMultiImage }
  25. Type
  26.   TDBMultiImage = class(TCustomControl)
  27.   private
  28.     FDataLink           :  TFieldDataLink;
  29.     FPicture            :  TPicture;
  30.     FBorderStyle        :  TBorderStyle;
  31.     FAutoDisplay        :  Boolean;
  32.     FStretch            :  Boolean;
  33.     FCenter             :  Boolean;
  34.     FPictureLoaded      :  Boolean;
  35.     FUpdateAsJpeg       :  Boolean;
  36.     FReserved           :  Byte;
  37.     Fdither             :  byte;
  38.     FResolution         :  byte;
  39.     FSaveQuality        :  byte;
  40.     FSaveSmooth         :  byte;
  41.     {scrolling message stuff}
  42.     BitMsg              :  TBitmap;
  43.     SMessageLeft        :  Integer;
  44.     SMessageRight       :  Integer;
  45.     SMessageTop         :  Integer;
  46.     ScreenWd            :  Integer;
  47.     ScreenHt            :  Integer;
  48.     BitWidth            :  Integer;
  49.     MessageRunning      :  Boolean;
  50.     DelayCounter        :  LongInt;
  51.     OldColor            :  TColor;
  52.     MmsgCount           :  Integer;
  53.     {end scrolling message stuff}
  54.     procedure DataChange(Sender: TObject);
  55.     function GetDataField: string;
  56.     function GetDataSource: TDataSource;
  57.     function GetField: TField;
  58.     function GetReadOnly: Boolean;
  59.     procedure PictureChanged(Sender: TObject);
  60.     procedure SetAutoDisplay(Value: Boolean);
  61.     procedure SetBorderStyle(Value: TBorderStyle);
  62.     procedure SetCenter(Value: Boolean);
  63.     procedure SetDataField(const Value: string);
  64.     procedure SetDataSource(Value: TDataSource);
  65.     procedure SetPicture(Value: TPicture);
  66.     procedure SetReadOnly(Value: Boolean);
  67.     procedure SetStretch(Value: Boolean);
  68.     procedure UpdateData(Sender: TObject);
  69.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  70.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  71.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  72.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  73.     procedure WMCut(var Message: TMessage); message WM_CUT;
  74.     procedure WMCopy(var Message: TMessage); message WM_COPY;
  75.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  76.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  77.   protected
  78.     procedure CreateParams(var Params: TCreateParams); override;
  79.     function GetPalette: HPALETTE; override;
  80.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  81.     procedure KeyPress(var Key: Char); override;
  82.     procedure Notification(AComponent: TComponent;
  83.       Operation: TOperation); override;
  84.     procedure Paint; override;
  85.     function GetSmooth : Byte;
  86.     procedure SetSmooth(smooth : Byte);
  87.     function GetQuality : Byte;
  88.     procedure SetQuality(Quality : Byte);
  89.     function GetDither : Byte;
  90.     procedure SetDither(dith : Byte);
  91.     function GetRes : Byte;
  92.     procedure SetRes(res : Byte);
  93.     procedure PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  94.     procedure PrintBitMap(X, Y, pWidth, pHeight: Integer);
  95.     procedure LoadMessageFromStream(MessageStream : TStream);
  96.     Procedure MoveMsg(Var WinMsg : TMessage); message WM_Trigger;
  97.     Function Delay(Ms : Integer) : boolean;
  98.     Function SaveMessageToStream(MFont  : Tfont;
  99.                                   Mspeed : integer;
  100.                                   MColor : Tcolor;
  101.                                   MMsg   : String) : Boolean;
  102.   public
  103.     BFiletype           :  String;
  104.     Bwidth              :  Integer;
  105.     BHeight             :  Integer;
  106.     Bbitspixel          :  Integer;
  107.     Bplanes             :  Integer;
  108.     Bnumcolors          :  Integer;
  109.     BSize               :  Longint;
  110.     Bcompression        :  String;
  111.     {scrolling message stuff}
  112.     MsgText             :  String;
  113.     MsgFont             :  TFont;
  114.     MsgBkGrnd           :  TColor;
  115.     MsgSpeed            :  Integer;
  116.     {End scrolling message stuff}
  117.     constructor Create(AOwner: TComponent); override;
  118.     destructor Destroy; override;
  119.     procedure CopyToClipboard;
  120.     procedure CutToClipboard;
  121.     procedure LoadPicture;
  122.     procedure PasteFromClipboard;
  123.     procedure LoadFromFile(filename : TFilename);
  124.     procedure SaveToFile(filename : TFilename);
  125.     procedure SaveToFileAsBMP(filename : TFilename);
  126.     procedure SaveToFileAsJpeg(filename : TFilename);
  127.     function GetInfoAndType : String;
  128.     property Field: TField read GetField;
  129.     property Picture: TPicture read FPicture write SetPicture;
  130.     Procedure Trigger;
  131.     Function CreateMessage : Boolean;
  132.     procedure NewMessage;
  133.     Procedure FreeMsg;
  134.     procedure PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  135.   published
  136.     property JPegDither : Byte read GetDither write SetDither;
  137.     property JPegResolution : Byte read GetRes write SetRes;
  138.     property JPegSaveQuality : Byte read GetQuality write SetQuality;
  139.     property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
  140.     property UPdateBlobAsJpeg : Boolean read FUpdateAsJpeg write FUpdateAsJpeg;
  141.     property Align;
  142.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  143.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  144.     property Center: Boolean read FCenter write SetCenter default True;
  145.     property Color;
  146.     property Ctl3D;
  147.     property DataField: string read GetDataField write SetDataField;
  148.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  149.     property DragCursor;
  150.     property DragMode;
  151.     property Enabled;
  152.     property Font;
  153.     property ParentColor default False;
  154.     property ParentCtl3D;
  155.     property ParentFont;
  156.     property ParentShowHint;
  157.     property PopupMenu;
  158.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  159.     property ShowHint;
  160.     property Stretch: Boolean read FStretch write SetStretch default False;
  161.     property TabOrder;
  162.     property TabStop default True;
  163.     property Visible;
  164.     property OnClick;
  165.     property OnDblClick;
  166.     property OnDragDrop;
  167.     property OnDragOver;
  168.     property OnEndDrag;
  169.     property OnEnter;
  170.     property OnExit;
  171.     property OnKeyDown;
  172.     property OnKeyPress;
  173.     property OnKeyUp;
  174.     property OnMouseDown;
  175.     property OnMouseMove;
  176.     property OnMouseUp;
  177.   end;
  178.  
  179. {TDBMediaPlayer}
  180. Type
  181.   TDBMediaPlayer = class(TMediaPlayer)
  182.   {Just incase you/we want to add some stuff in the
  183.    future we derived a seperate object.}
  184. end;
  185.  
  186.  
  187. {TDBMultiMedia }
  188. Type
  189.   TDBMultiMedia = class(TCustomControl)
  190.   private
  191.     FDataLink           :  TFieldDataLink;
  192.     FPicture            :  TPicture;
  193.     FBorderStyle        :  TBorderStyle;
  194.     FAutoDisplay        :  Boolean;
  195.     FStretch            :  Boolean;
  196.     FCenter             :  Boolean;
  197.     FPictureLoaded      :  Boolean;
  198.     FUpdateAsJpeg       :  Boolean;
  199.     FAutoPlayMM         :  Boolean;
  200.     FAutoMMHide         :  Boolean;
  201.     FAutoRePlayMM       :  Boolean;
  202.     FReserved           :  Byte;
  203.     Fdither             :  byte;
  204.     FResolution         :  byte;
  205.     FSaveQuality        :  byte;
  206.     FSaveSmooth         :  byte;
  207.     FMediaPlayer        :  TDBMediaPlayer;
  208.     FMOVTempFile        :  TFileName;
  209.     FMPGTempFile        :  TFileName;
  210.     FAVITempFile        :  TFileName;
  211.     FWAVTempFile        :  TFileName;
  212.     FMIDTempFile        :  TFileName;
  213.     FRMITempFile        :  TFileName;
  214.     FTempFilePath       :  String;
  215.     {scrolling message stuff}
  216.     BitMsg              :  TBitmap;
  217.     SMessageLeft        :  Integer;
  218.     SMessageRight       :  Integer;
  219.     SMessageTop         :  Integer;
  220.     ScreenWd            :  Integer;
  221.     ScreenHt            :  Integer;
  222.     BitWidth            :  Integer;
  223.     MessageRunning      :  Boolean;
  224.     DelayCounter        :  LongInt;
  225.     OldColor            :  TColor;
  226.     MmsgCount           :  Integer;
  227.     {end scrolling message stuff}
  228.     procedure DataChange(Sender: TObject);
  229.     function GetDataField: string;
  230.     function GetDataSource: TDataSource;
  231.     function GetMediaPlayer: TDBMediaPlayer;
  232.     function GetField: TField;
  233.     function GetReadOnly: Boolean;
  234.     procedure PictureChanged(Sender: TObject);
  235.     procedure SetAutoDisplay(Value: Boolean);
  236.     procedure SetBorderStyle(Value: TBorderStyle);
  237.     procedure SetCenter(Value: Boolean);
  238.     procedure SetDataField(const Value: string);
  239.     procedure SetDataSource(Value: TDataSource);
  240.     procedure SetMediaPlayer(Value: TDBMediaPlayer);
  241.     procedure SetPicture(Value: TPicture);
  242.     procedure SetReadOnly(Value: Boolean);
  243.     procedure SetStretch(Value: Boolean);
  244.     procedure UpdateData(Sender: TObject);
  245.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  246.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  247.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  248.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  249.     procedure WMCut(var Message: TMessage); message WM_CUT;
  250.     procedure WMCopy(var Message: TMessage); message WM_COPY;
  251.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  252.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  253.   protected
  254.     procedure CreateParams(var Params: TCreateParams); override;
  255.     function GetPalette: HPALETTE; override;
  256.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  257.     procedure KeyPress(var Key: Char); override;
  258.     procedure Notification(AComponent: TComponent;
  259.       Operation: TOperation); override;
  260.     procedure Paint; override;
  261.     function GetSmooth : Byte;
  262.     procedure SetSmooth(smooth : Byte);
  263.     function GetQuality : Byte;
  264.     procedure SetQuality(Quality : Byte);
  265.     function GetDither : Byte;
  266.     procedure SetDither(dith : Byte);
  267.     function GetRes : Byte;
  268.     procedure SetRes(res : Byte);
  269.     function GetTempPath : String;
  270.     procedure SetTempPath(temppath : string);
  271.     function AddBackSlash(DirName : string) : string;
  272.     Procedure CleanUpMultiMedia;
  273.     function IsValidMultiMedia(Name : PChar) : boolean;
  274.     procedure TimerNotify(var Message: TMessage); message WM_TIMER;
  275.     procedure PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  276.     procedure PrintBitMap(X, Y, pWidth, pHeight: Integer);
  277.     procedure LoadMessageFromStream(MessageStream : TStream);
  278.     Procedure MoveMsg(Var WinMsg : TMessage); message WM_Trigger;
  279.     Function Delay(Ms : Integer) : boolean;
  280.     Function SaveMessageToStream(MFont  : Tfont;
  281.                                   Mspeed : integer;
  282.                                   MColor : Tcolor;
  283.                                   MMsg   : String) : Boolean;
  284.   public
  285.     BFiletype           :  String;
  286.     Bwidth              :  Integer;
  287.     BHeight             :  Integer;
  288.     Bbitspixel          :  Integer;
  289.     Bplanes             :  Integer;
  290.     Bnumcolors          :  Integer;
  291.     BSize               :  Longint;
  292.     Bcompression        :  String;
  293.     {scrolling message stuff}
  294.     MsgText             :  String;
  295.     MsgFont             :  TFont;
  296.     MsgBkGrnd           :  TColor;
  297.     MsgSpeed            :  Integer;
  298.     {End scrolling message stuff}
  299.     constructor Create(AOwner: TComponent); override;
  300.     destructor Destroy; override;
  301.     procedure CopyToClipboard;
  302.     procedure CutToClipboard;
  303.     procedure LoadMedia;
  304.     procedure PasteFromClipboard;
  305.     procedure LoadFromFile(filename : TFilename);
  306.     procedure SaveToFile(filename : TFilename);
  307.     procedure SaveToFileAsBMP(filename : TFilename);
  308.     procedure SaveToFileAsJpeg(filename : TFilename);
  309.     function GetInfoAndType : String;
  310.     function GetMultiMediaExtensions : String;
  311.     property Field: TField read GetField;
  312.     property Picture: TPicture read FPicture write SetPicture;
  313.     Procedure Trigger;
  314.     Function CreateMessage : Boolean;
  315.     procedure NewMessage;
  316.     Procedure FreeMsg;
  317.     procedure PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  318.   published
  319.     property JPegDither : Byte read GetDither write SetDither;
  320.     property JPegResolution : Byte read GetRes write SetRes;
  321.     property JPegSaveQuality : Byte read GetQuality write SetQuality;
  322.     property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
  323.     property UPdateBlobAsJpeg : Boolean read FUpdateAsJpeg write FUpdateAsJpeg;
  324.     property AutoPlayMultiMedia : Boolean read FAutoPlayMM write FAutoPlayMM;
  325.     property AutoRePlayMultiMedia : Boolean read FAutoRePlayMM write FAutoRePlayMM;
  326.     property AutoHideMediaPlayer : Boolean read FAutoMMHide write FAutoMMHide;
  327.     property PathForTempFile : string read GetTempPath write SetTempPath;
  328.     property Align;
  329.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  330.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  331.     property Center: Boolean read FCenter write SetCenter default True;
  332.     property Color;
  333.     property Ctl3D;
  334.     property DataField: string read GetDataField write SetDataField;
  335.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  336.     property MediaPlayer: TDBMediaPlayer read GetMediaPlayer write SetmediaPlayer;
  337.     property DragCursor;
  338.     property DragMode;
  339.     property Enabled;
  340.     property Font;
  341.     property ParentColor default False;
  342.     property ParentCtl3D;
  343.     property ParentFont;
  344.     property ParentShowHint;
  345.     property PopupMenu;
  346.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  347.     property ShowHint;
  348.     property Stretch: Boolean read FStretch write SetStretch default False;
  349.     property TabOrder;
  350.     property TabStop default True;
  351.     property Visible;
  352.     property OnClick;
  353.     property OnDblClick;
  354.     property OnDragDrop;
  355.     property OnDragOver;
  356.     property OnEndDrag;
  357.     property OnEnter;
  358.     property OnExit;
  359.     property OnKeyDown;
  360.     property OnKeyPress;
  361.     property OnKeyUp;
  362.     property OnMouseDown;
  363.     property OnMouseMove;
  364.     property OnMouseUp;
  365.   end;
  366.  
  367.  
  368.  
  369.  
  370. var
  371.  TDBMultiImageCallBack : TCallBackFunction;
  372.  TDBMultiMediaCallBack : TCallBackFunction;
  373.  
  374. {------------------------------------------------------------------------}
  375. implementation
  376. uses Consts, DBIErrs, DBITypes, Clipbrd, DBConsts, Dialogs;
  377.  
  378. {------------------------------------------------------------------------}
  379.  
  380. {TDBMultiImage}
  381. constructor TDBMultiImage.Create(AOwner: TComponent);
  382. begin
  383.   inherited Create(AOwner);
  384.   ControlStyle := ControlStyle + [csFramed, csOpaque];
  385.   Width := 105;
  386.   Height := 105;
  387.   TabStop := True;
  388.   ParentColor := False;
  389.   FPicture := TPicture.Create;
  390.   FPicture.OnChange := PictureChanged;
  391.   FBorderStyle := bsSingle;
  392.   FAutoDisplay := True;
  393.   FCenter := True;
  394.   FUpdateAsJpeg := True;
  395.   Fdither:=4;
  396.   FResolution:=8;
  397.   FSaveQuality:=25;
  398.   FSaveSmooth:=0;
  399.   FDataLink := TFieldDataLink.Create;
  400.   FDataLink.Control := Self;
  401.   FDataLink.OnDataChange := DataChange;
  402.   FDataLink.OnUpdateData := UpdateData;
  403.   MsgFont:=TFont.Create;
  404.   BitMsg := TBitmap.Create;
  405.   MessageRunning:=False;
  406.   SetupMsg:=Nil;
  407.   DelayCounter:=0;
  408.   OldColor:=Color;
  409. end;
  410. {------------------------------------------------------------------------}
  411.  
  412. destructor TDBMultiImage.Destroy;
  413. begin
  414.   FPicture.Free;
  415.   FDataLink.Free;
  416.   MsgFont.Free;
  417.   BitMsg.Free;
  418.   FDataLink := nil;
  419.   inherited Destroy;
  420. end;
  421. {------------------------------------------------------------------------}
  422.  
  423. function TDBMultiImage.GetDataSource: TDataSource;
  424. begin
  425.   Result := FDataLink.DataSource;
  426. end;
  427. {------------------------------------------------------------------------}
  428.  
  429. procedure TDBMultiImage.SetDataSource(Value: TDataSource);
  430. begin
  431.   FDataLink.DataSource := Value;
  432. end;
  433. {------------------------------------------------------------------------}
  434.  
  435. function TDBMultiImage.GetDataField: string;
  436. begin
  437.   Result := FDataLink.FieldName;
  438. end;
  439. {------------------------------------------------------------------------}
  440.  
  441. procedure TDBMultiImage.SetDataField(const Value: string);
  442. begin
  443.   FDataLink.FieldName := Value;
  444. end;
  445. {------------------------------------------------------------------------}
  446.  
  447. function TDBMultiImage.GetReadOnly: Boolean;
  448. begin
  449.   Result := FDataLink.ReadOnly;
  450. end;
  451. {------------------------------------------------------------------------}
  452.  
  453. procedure TDBMultiImage.SetReadOnly(Value: Boolean);
  454. begin
  455.   FDataLink.ReadOnly := Value;
  456. end;
  457. {------------------------------------------------------------------------}
  458.  
  459. function TDBMultiImage.GetField: TField;
  460. begin
  461.   Result := FDataLink.Field;
  462. end;
  463. {------------------------------------------------------------------------}
  464.  
  465. function TDBMultiImage.GetPalette: HPALETTE;
  466. begin
  467.   Result := 0;
  468.   if FPicture.Graphic is TBitmap then
  469.     Result := TBitmap(FPicture.Graphic).Palette;
  470. end;
  471. {------------------------------------------------------------------------}
  472.  
  473. procedure TDBMultiImage.SetAutoDisplay(Value: Boolean);
  474. begin
  475.   if FAutoDisplay <> Value then
  476.   begin
  477.     FAutoDisplay := Value;
  478.     if Value then LoadPicture;
  479.   end;
  480. end;
  481. {------------------------------------------------------------------------}
  482.  
  483. procedure TDBMultiImage.SetBorderStyle(Value: TBorderStyle);
  484. begin
  485.   if FBorderStyle <> Value then
  486.   begin
  487.     FBorderStyle := Value;
  488.     RecreateWnd;
  489.   end;
  490. end;
  491. {------------------------------------------------------------------------}
  492.  
  493. procedure TDBMultiImage.SetCenter(Value: Boolean);
  494. begin
  495.   if FCenter <> Value then
  496.   begin
  497.     FCenter := Value;
  498.     Invalidate;
  499.   end;
  500. end;
  501. {------------------------------------------------------------------------}
  502.  
  503. procedure TDBMultiImage.SetPicture(Value: TPicture);
  504. begin
  505.   FPicture.Assign(Value);
  506. end;
  507. {------------------------------------------------------------------------}
  508.  
  509. procedure TDBMultiImage.SetStretch(Value: Boolean);
  510. begin
  511.   if FStretch <> Value then
  512.   begin
  513.     FStretch := Value;
  514.     Invalidate;
  515.   end;
  516. end;
  517. {------------------------------------------------------------------------}
  518.  
  519. procedure TDBMultiImage.Paint;
  520. var
  521.   W, H: Integer;
  522.   R: TRect;
  523.   S: string[63];
  524. begin
  525.   with Canvas do
  526.   begin
  527.     Brush.Style := bsSolid;
  528.     Brush.Color := Color;
  529.     if FPictureLoaded then
  530.     begin
  531.       if Stretch then
  532.         if Picture.Graphic.Empty then
  533.           FillRect(ClientRect) else
  534.           StretchDraw(ClientRect, Picture.Graphic)
  535.       else
  536.       begin
  537.         SetRect(R, 0, 0, Picture.Width, Picture.Height);
  538.         if Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  539.           (ClientHeight - Picture.Height) div 2);
  540.         StretchDraw(R, Picture.Graphic);
  541.         ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  542.         FillRect(ClientRect);
  543.         SelectClipRgn(Handle, 0);
  544.       end;
  545.     end else
  546.     begin
  547.       Font := Self.Font;
  548.       if FDataLink.Field <> nil then
  549.         S := FDataLink.Field.DisplayLabel else
  550.         S := Name;
  551.       S := '(' + S + ')';
  552.       W := TextWidth(S);
  553.       H := TextHeight(S);
  554.       R := ClientRect;
  555.       TextRect(R, (R.Right - W) div 2, (R.Bottom - H) div 2, S);
  556.     end;
  557.     if (GetParentForm(Self).ActiveControl = Self) and
  558.       not (csDesigning in ComponentState) then
  559.     begin
  560.       Brush.Color := clWindowFrame;
  561.       FrameRect(ClientRect);
  562.     end;
  563.   end;
  564.   if (MessageRunning) and (Picture = nil) then FreeMsg;
  565. end;
  566. {------------------------------------------------------------------------}
  567.  
  568. procedure TDBMultiImage.PictureChanged(Sender: TObject);
  569. begin
  570.   FDataLink.Modified;
  571.   FPictureLoaded := True;
  572.   Invalidate;
  573. end;
  574. {------------------------------------------------------------------------}
  575.  
  576. procedure TDBMultiImage.Notification(AComponent: TComponent;
  577.   Operation: TOperation);
  578. begin
  579.   inherited Notification(AComponent, Operation);
  580.   if (Operation = opRemove) and (FDataLink <> nil) and
  581.     (AComponent = DataSource) then DataSource := nil;
  582. end;
  583. {------------------------------------------------------------------------}
  584.  
  585. procedure TDBMultiImage.LoadPicture;
  586. var
  587.    Stream       :  TMemoryStream;
  588.    BitMap       :  TBitMap;
  589.    Cursor       :  hCursor;
  590.    temp         :  string;
  591. begin
  592.   if not FPictureLoaded and (FDataLink.Field is TBlobField) then begin
  593.  
  594.    if TBlobField(FDataLink.Field).IsNull then exit;
  595.  
  596.    Temp:=GetInfoAndType;
  597.  
  598.    if Temp = 'SCM' then begin
  599.       Stream:=TMemoryStream.Create;
  600.       try
  601.         Cursor := SetCursor(LoadCursor(0,idc_Wait));
  602.          FreeMsg;
  603.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  604.          LoadMessageFromStream(Stream);
  605.          if @TDBMultiMediaCallBack <> nil then
  606.            TDBMultiMediaCallBack(0);
  607.        finally
  608.          SetCursor(Cursor);
  609.          Stream.Free;
  610.        end;
  611.    end else
  612.    if Temp = 'GIF' then begin
  613.       Stream:=TMemoryStream.Create;
  614.       BitMap:=TBitMap.Create;
  615.       try
  616.          FreeMsg;
  617.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  618.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  619.          if not gifblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiImageCallBack) then begin
  620.             MessageDlg('Invallid or empty GIF blobfield', mtInformation, [mbOk], 0);
  621.             Picture.Assign(Nil);
  622.          end else
  623.             Picture.Assign(BitMap);
  624.          finally
  625.             SetCursor(Cursor);
  626.             BitMap.free;
  627.             Stream.Free;
  628.          end;
  629.    end else
  630.    if Temp = 'PCX' then begin
  631.       Stream:=TMemoryStream.Create;
  632.       BitMap:=TBitMap.Create;
  633.       try
  634.          FreeMsg;
  635.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  636.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  637.          if not pcxblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiImageCallBack) then begin
  638.             MessageDlg('Invallid or empty PCX blobfield', mtInformation, [mbOk], 0);
  639.             Picture.Assign(Nil);
  640.          end else
  641.             Picture.Assign(BitMap);
  642.          finally
  643.           SetCursor(Cursor);
  644.           BitMap.free;
  645.           Stream.Free;
  646.          end;
  647.    end else
  648.    if Temp = 'BMP' then begin
  649.       Stream:=TMemoryStream.Create;
  650.       BitMap:=TBitMap.Create;
  651.       try
  652.          FreeMsg;
  653.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  654.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  655.          if not bmpblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiImageCallBack) then begin
  656.             MessageDlg('Invallid or empty BMP blobfield', mtInformation, [mbOk], 0);
  657.             Picture.Assign(Nil);
  658.          end else
  659.             Picture.Assign(BitMap);
  660.          finally
  661.           SetCursor(Cursor);
  662.           BitMap.free;
  663.           Stream.Free;
  664.          end;
  665.    end else
  666.    if Temp = 'JPG' then begin
  667.       Stream:=TMemoryStream.Create;
  668.       BitMap:=TBitMap.Create;
  669.       if FResolution <> 4 then
  670.       if FResolution <> 8 then
  671.       if FResolution <> 24 then FResolution:=8;
  672.       if (FDither < 0) or (FDither > 4) then FDither:=4;
  673.       try
  674.          FreeMsg;
  675.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  676.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  677.          if not jpgblob(Stream.Memory,Stream.Size, FResolution, Fdither, Bitmap, TDBMultiImageCallBack) then begin
  678.             MessageDlg('Invallid or empty Jpeg Blobfield', mtInformation, [mbOk], 0);
  679.             Picture.Assign(Nil);
  680.          end else
  681.              Picture.Assign(BitMap);
  682.          finally
  683.              SetCursor(Cursor);
  684.              BitMap.free;
  685.              Stream.Free;
  686.          end;
  687.     end;
  688.     GetInfoAndType;
  689.  end;
  690. end;
  691. {------------------------------------------------------------------------}
  692.  
  693. procedure TDBMultiImage.DataChange(Sender: TObject);
  694. begin
  695.   Picture.Graphic := nil;
  696.   FPictureLoaded := False;
  697.   if FAutoDisplay then LoadPicture;
  698. end;
  699. {------------------------------------------------------------------------}
  700.  
  701. procedure TDBMultiImage.UpdateData(Sender: TObject);
  702. var
  703.    Stream       :  TMemoryStream;
  704.    Cursor       :  hCursor;
  705.    Usize        :  longInt;
  706.    x,y          :  longInt;
  707.    p            :  Pointer;
  708. begin
  709.   if FDataLink.Field is TBlobField then begin
  710.  
  711.     if Picture.Graphic is TBitmap then begin
  712.       x:=Picture.BitMap.Width;
  713.       y:=Picture.BitMap.Height;
  714.  
  715.       y:=y+(y div 5);
  716.       x:=x+(x div 5);
  717.  
  718.       Usize:=(y * x);
  719.  
  720.       if Usize < 90000 then Usize:=Usize*2;
  721.  
  722.       {Since we can't know how much memory we need to allocate
  723.       to write the picture to the stream we need to guess it. This
  724.       is done using the width and height of the bitmap. After the call
  725.       to the dll using PUTJPGBLOB or PUTBMPBLOB Usize contains the
  726.       correct size of the Jpeg stored in P^. You can increase or decrease
  727.       the guessed memory by altering the Div by. For instance
  728.  
  729.       y:=y+(y div 3);
  730.       x:=x+(x div 3);
  731.  
  732.       will allocate more memory then
  733.  
  734.       y:=y+(y div 6);
  735.       x:=x+(x div 6);
  736.  
  737.       We played it on the save side. Use this "guess work" very carefully}
  738.  
  739.  
  740.       P := GlobalAllocPtr(HeapAllocFlags, Usize);
  741.       if P = Nil then begin
  742.         MessageDlg('Error allocation blob memory', mtInformation, [mbOk], 0);
  743.         exit;
  744.       end;
  745.  
  746.       if FUpdateAsJpeg then begin
  747.          if not putjpgblob(P, USize, FSaveQuality, FSaveSmooth, Picture.Bitmap, TDBMultiImageCallBack) then
  748.            MessageDlg('Jpeg BLOB Write Error', mtInformation, [mbOk], 0);
  749.       end else begin
  750.          if not putbmpblob(P, USize, Picture.Bitmap, TDBMultiImageCallBack) then
  751.            MessageDlg('BMP BLOB Write Error', mtInformation, [mbOk], 0);
  752.       end;
  753.  
  754.       Stream:=TMemoryStream.Create;
  755.       Stream.Write(P^,USize);
  756.       GlobalFreePtr(P);
  757.  
  758.       try
  759.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  760.       finally
  761.         Stream.Free;
  762.       end;
  763.  
  764.     end else
  765.       TBlobField(FDataLink.Field).Clear;
  766.    end;
  767.    GetInfoAndType;
  768. end;
  769. {------------------------------------------------------------------------}
  770.  
  771. procedure TDBMultiImage.CopyToClipboard;
  772. begin
  773.   if Picture.Graphic <> nil then Clipboard.Assign(Picture);
  774. end;
  775. {------------------------------------------------------------------------}
  776.  
  777. procedure TDBMultiImage.CutToClipboard;
  778. begin
  779.   if Picture.Graphic <> nil then
  780.   begin
  781.     CopyToClipboard;
  782.     if FDataLink.Edit then
  783.       Picture.Graphic := nil;
  784.   end;
  785. end;
  786. {------------------------------------------------------------------------}
  787.  
  788. procedure TDBMultiImage.PasteFromClipboard;
  789. begin
  790.   if Clipboard.HasFormat(CF_PICTURE) and FDataLink.Edit then begin
  791.     MessageRunning:=False;
  792.     Picture.Assign(Clipboard);
  793.    end;
  794. end;
  795. {------------------------------------------------------------------------}
  796.  
  797. procedure TDBMultiImage.CreateParams(var Params: TCreateParams);
  798. begin
  799.   inherited CreateParams(Params);
  800.   if FBorderStyle = bsSingle then
  801.     Params.Style := Params.Style or WS_BORDER;
  802. end;
  803. {------------------------------------------------------------------------}
  804.  
  805. procedure TDBMultiImage.KeyDown(var Key: Word; Shift: TShiftState);
  806. begin
  807.   inherited KeyDown(Key, Shift);
  808.   case Key of
  809.     VK_INSERT:
  810.       if ssShift in Shift then PasteFromClipBoard else
  811.         if ssCtrl in Shift then CopyToClipBoard;
  812.     VK_DELETE:
  813.       if ssShift in Shift then CutToClipBoard;
  814.   end;
  815. end;
  816. {------------------------------------------------------------------------}
  817.  
  818. procedure TDBMultiImage.KeyPress(var Key: Char);
  819. begin
  820.   inherited KeyPress(Key);
  821.   case Key of
  822.     ^X: CutToClipBoard;
  823.     ^C: CopyToClipBoard;
  824.     ^V: PasteFromClipBoard;
  825.     #13: LoadPicture;
  826.     #27: FDataLink.Reset;
  827.   end;
  828. end;
  829. {------------------------------------------------------------------------}
  830.  
  831. procedure TDBMultiImage.CMEnter(var Message: TCMEnter);
  832. begin
  833.   Invalidate; { Draw the focus marker }
  834.   inherited;
  835. end;
  836. {------------------------------------------------------------------------}
  837.  
  838. procedure TDBMultiImage.CMExit(var Message: TCMExit);
  839. begin
  840.   Invalidate; { Erase the focus marker }
  841.   inherited;
  842. end;
  843. {------------------------------------------------------------------------}
  844.  
  845. procedure TDBMultiImage.CMTextChanged(var Message: TMessage);
  846. begin
  847.   inherited;
  848.   if not FPictureLoaded then Invalidate;
  849. end;
  850. {------------------------------------------------------------------------}
  851.  
  852. procedure TDBMultiImage.WMLButtonDown(var Message: TWMLButtonDown);
  853. begin
  854.   if TabStop and CanFocus then SetFocus;
  855.   inherited;
  856. end;
  857. {------------------------------------------------------------------------}
  858.  
  859. procedure TDBMultiImage.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  860. begin
  861.   LoadPicture;
  862.   inherited;
  863. end;
  864. {------------------------------------------------------------------------}
  865.  
  866. procedure TDBMultiImage.WMCut(var Message: TMessage);
  867. begin
  868.   CutToClipboard;
  869. end;
  870. {------------------------------------------------------------------------}
  871.  
  872. procedure TDBMultiImage.WMCopy(var Message: TMessage);
  873. begin
  874.   CopyToClipboard;
  875. end;
  876. {------------------------------------------------------------------------}
  877.  
  878. procedure TDBMultiImage.WMPaste(var Message: TMessage);
  879. begin
  880.   PasteFromClipboard;
  881. end;
  882. {------------------------------------------------------------------------}
  883.  
  884. procedure TDBMultiImage.LoadFromFile(filename : TFilename);
  885. var
  886.    Cursor       :  hCursor;
  887. begin
  888.   if not FileExists(filename) then begin
  889.     MessageDlg('File not found', mtInformation, [mbOk], 0);
  890.     exit;
  891.   end;
  892.  
  893.   if UpperCase(ExtractFileExt(filename)) <> '.JPG' then
  894.   if UpperCase(ExtractFileExt(filename)) <> '.GIF' then
  895.   if UpperCase(ExtractFileExt(filename)) <> '.PCX' then
  896.   if UpperCase(ExtractFileExt(filename)) <> '.BMP' then
  897.   if UpperCase(ExtractFileExt(filename)) <> '.SCM' then
  898.   begin
  899.     MessageDlg('Not a Jpeg, Gif, Pcx, Scm or Bmp File', mtInformation, [mbOk], 0);
  900.     exit;
  901.   end;
  902.  
  903.   if FDataLink.Field is TBlobField then begin
  904.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  905.     TBlobField(FDataLink.Field).LoadFromFile(filename);
  906.     SetCursor(Cursor);
  907.   end else begin
  908.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  909.     exit;
  910.   end;
  911.   GetInfoAndType;
  912. end;
  913. {------------------------------------------------------------------------}
  914.  
  915. procedure TDBMultiImage.SaveToFile(filename : TFilename);
  916. var
  917.   Cursor       :  hCursor;
  918. begin
  919.   if FDataLink.Field is TBlobField then begin
  920.  
  921.     if TBlobField(FDataLink.Field).IsNull then begin
  922.        MessageDlg('Can''t save, blobfield is empty', mtInformation, [mbOk], 0);
  923.        exit;
  924.     end;
  925.  
  926.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  927.     TBlobField(FDataLink.Field).SaveToFile(filename);
  928.     GetInfoAndType;
  929.     SetCursor(Cursor)
  930.  
  931.   end else begin
  932.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  933.     exit;
  934.   end;
  935. end;
  936. {------------------------------------------------------------------------}
  937.  
  938. procedure TDBMultiImage.SaveToFileAsBMP(filename : TFilename);
  939. var
  940.   Cursor       :  hCursor;
  941. begin
  942.   if FDataLink.Field is TBlobField then begin
  943.  
  944.     if TBlobField(FDataLink.Field).IsNull then begin
  945.        MessageDlg('Can''t save, blobfield bitmap is empty', mtInformation, [mbOk], 0);
  946.        exit;
  947.     end;
  948.  
  949.     if picture.bitmap.empty then begin
  950.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  951.                   mtInformation, [mbOk], 0);
  952.        exit;
  953.     end;
  954.  
  955.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  956.  
  957.     if not putbmpfile(FileName, picture.Bitmap, TDBMultiImageCallBack) then begin
  958.       SetCursor(Cursor);
  959.       MessageDlg('Writing bmp file failed', mtInformation, [mbOk], 0);
  960.       exit;
  961.     end;
  962.  
  963.     GetInfoAndType
  964.  
  965.   end else begin
  966.     SetCursor(Cursor);
  967.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  968.     exit;
  969.   end;
  970.  
  971.   SetCursor(Cursor);
  972. end;
  973. {------------------------------------------------------------------------}
  974.  
  975. procedure TDBMultiImage.SaveToFileAsJpeg(filename : TFilename);
  976. var
  977.   Cursor       :  hCursor;
  978. begin
  979.   if FDataLink.Field is TBlobField then begin
  980.  
  981.     if TBlobField(FDataLink.Field).IsNull then begin
  982.        MessageDlg('Can''t save, blobfield bitmap is empty', mtInformation, [mbOk], 0);
  983.        exit;
  984.     end;
  985.  
  986.     if picture.bitmap = nil then begin
  987.        MessageDlg('Can''t save, image is not displayed', mtInformation, [mbOk], 0);
  988.        exit;
  989.     end;
  990.  
  991.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  992.  
  993.     if not putjpgfile(FileName, FSaveQuality, FSaveSmooth, picture.Bitmap, TDBMultiImageCallBack) then begin
  994.       SetCursor(Cursor);
  995.       MessageDlg('Writing jpg file failed', mtInformation, [mbOk], 0);
  996.       exit;
  997.     end;
  998.  
  999.     GetInfoAndType
  1000.  
  1001.   end else begin
  1002.     SetCursor(Cursor);
  1003.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1004.     exit;
  1005.   end;
  1006.  
  1007.   SetCursor(Cursor);
  1008. end;
  1009.  
  1010.  
  1011. {------------------------------------------------------------------------}
  1012.  
  1013. function TDBMultiImage.GetInfoAndType : String;
  1014. var
  1015.  Stream       :  TMemoryStream;
  1016.  Hdr          :  Array[0..45] of char;
  1017.  i            :  Byte;
  1018. begin
  1019.   if (FDataLink.Field is TBlobField) then
  1020.    if TBlobField(FDataLink.Field).IsNull then exit;
  1021.  
  1022.    BFileType := 'Empty';
  1023.    Bwidth:=-1;
  1024.    BHeight:=-1;
  1025.    Bbitspixel:=-1;
  1026.    Bplanes:=-1;
  1027.    Bnumcolors:=-1;
  1028.    Bcompression:='-1';
  1029.    BSize:=-1;
  1030.    GetInfoAndType :='-1';
  1031.  
  1032.    Stream:=TMemoryStream.Create;
  1033.    TBlobField(FDataLink.Field).SaveToStream(Stream);
  1034.  
  1035.   if Stream.Memory = nil then begin
  1036.      MessageDlg('Error allocation temporary blob memory', mtInformation, [mbOk], 0);
  1037.      exit;
  1038.   end;
  1039.  
  1040.   Stream.Seek(0,0);
  1041.   Stream.read(hdr,SizeOf(Hdr)-1);
  1042.  
  1043.   for i:=0 to SizeOf(hdr)-1 do
  1044.    if hdr[i] = #0 then hdr[i]:=' ';
  1045.  
  1046.   if StrPos(hdr,'kevinjan') <> nil then begin
  1047.         Bwidth:=-1;
  1048.         BHeight:=-1;
  1049.         Bbitspixel:=-1;
  1050.         Bplanes:=-1;
  1051.         Bnumcolors:=-1;
  1052.         Bcompression:='MSG';
  1053.         BSize:=Stream.Size;
  1054.         BFileType:= 'SCM';
  1055.         GetInfoAndType:='SCM';
  1056.         if Stream.Memory <> nil then Stream.Free;
  1057.         exit;
  1058.    end else
  1059.  
  1060.    if not GetBlobInfo(Stream.Memory,
  1061.                     Stream.Size,
  1062.                     BFileType,
  1063.                     Bwidth,
  1064.                     BHeight,
  1065.                     Bbitspixel,
  1066.                     Bplanes,
  1067.                     Bnumcolors,
  1068.                     Bcompression) then
  1069.     MessageDlg('blobfield getinfo failed', mtInformation, [mbOk], 0) else
  1070.     begin
  1071.          BSize:=Stream.Size;
  1072.          if UpperCase(BFileType) = 'GIF' then GetInfoAndType:='GIF' else
  1073.          if UpperCase(BFileType) = 'PCX' then GetInfoAndType:='PCX' else
  1074.          if UpperCase(BFileType) = 'JPEG' then GetInfoAndType:='JPG' else
  1075.          if UpperCase(BFileType) = 'BMP' then GetInfoAndType:='BMP';
  1076.     end;
  1077.   if Stream.Memory <> nil then Stream.Free;
  1078. end;
  1079. {------------------------------------------------------------------------}
  1080.  
  1081. function TDBMultiImage.GetSmooth : Byte;
  1082. begin
  1083.   GetSmooth:=FSaveSmooth;
  1084. end;
  1085. {------------------------------------------------------------------------}
  1086.  
  1087. procedure TDBMultiImage.SetSmooth(Smooth : Byte);
  1088. begin
  1089.   if (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
  1090.    FSaveSmooth:=Smooth;
  1091. end;
  1092. {------------------------------------------------------------------------}
  1093.  
  1094. function TDBMultiImage.GetQuality : Byte;
  1095. begin
  1096.   GetQuality:=FSaveQuality;
  1097. end;
  1098. {------------------------------------------------------------------------}
  1099.  
  1100. procedure TDBMultiImage.SetQuality(Quality : Byte);
  1101. begin
  1102.   if (Quality > 100) OR (Quality < 1) then FSaveQuality:=25 else
  1103.    FSaveQuality:=Quality;
  1104. end;
  1105. {------------------------------------------------------------------------}
  1106. function TDBMultiImage.GetDither : Byte;
  1107. begin
  1108.   GetDither:=Fdither
  1109. end;
  1110. {------------------------------------------------------------------------}
  1111.  
  1112. procedure TDBMultiImage.SetDither(dith : Byte);
  1113. begin
  1114.   Fdither:=4;
  1115.   case dith of
  1116.             0..4 :Fdither:=dith;
  1117.   end;
  1118. end;
  1119. {------------------------------------------------------------------------}
  1120.  
  1121. function TDBMultiImage.GetRes : Byte;
  1122. begin
  1123.   GetRes:=FResolution;
  1124. end;
  1125. {------------------------------------------------------------------------}
  1126.  
  1127.  
  1128. procedure TDBMultiImage.SetRes(res : Byte);
  1129. begin
  1130.   FResolution:=8;
  1131.   case res of
  1132.             4 :FResolution:=res;
  1133.             8 :FResolution:=res;
  1134.             24:FResolution:=res;
  1135.   end;
  1136. end;
  1137.  
  1138. {------------------------------------------------------------------------
  1139.  scrolling message stuff
  1140. ------------------------------------------------------------------------}
  1141.  
  1142. procedure TDBMultiImage.LoadMessageFromStream(MessageStream : TStream);
  1143. var
  1144.   Msg      : TLabel;
  1145. begin
  1146.   Picture.Assign(nil);
  1147.   ScreenWd:=Width;
  1148.   ScreenHt:=Height;
  1149.   Msg := TLabel.Create(Self);
  1150.   readmessagefromstream(MessageStream, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
  1151.   Refresh;
  1152.   if MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  1153.   Msg.Parent :=Self;
  1154.   Msg.Visible := False;
  1155.   Msg.Font := MsgFont;
  1156.   Msg.Caption := MsgText;
  1157.   BitWidth:=Msg.Width;
  1158.   SMessageLeft := ScreenWd;
  1159.   SMessageRight := ScreenWd + Msg.Width;
  1160.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  1161.   BitMsg.Width := Msg.Width;
  1162.   BitMsg.Height := Msg.Height;
  1163.   OldColor:=Color;
  1164.   Color:=MsgBkGrnd;
  1165.  
  1166.   with BitMsg.Canvas do begin
  1167.     Brush.Color := MsgBkGrnd;
  1168.     Font := Msg.Font;
  1169.     TextOut(0,0,Msg.Caption);
  1170.   end;
  1171.  
  1172.    Msg.Free;
  1173.    Msg := nil;
  1174.    MessageRunning:=True;
  1175. end;
  1176. {------------------------------------------------------------------------}
  1177.  
  1178. procedure TDBMultiImage.NewMessage;
  1179. var
  1180.   Msg      : TLabel;
  1181. begin
  1182.   if MsgText = '' then exit;
  1183.   if MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  1184.   Picture.Assign(nil);
  1185.   ScreenWd:=Width;
  1186.   ScreenHt:=Height;
  1187.   Msg := TLabel.Create(Self);
  1188.   Refresh;
  1189.   Msg.Parent :=Self;
  1190.   Msg.Visible := False;
  1191.   Msg.Font := MsgFont;
  1192.   Msg.Caption := MsgText;
  1193.   BitWidth:=Msg.Width;
  1194.   SMessageLeft := ScreenWd;
  1195.   SMessageRight := ScreenWd + Msg.Width;
  1196.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  1197.   BitMsg.Width := Msg.Width;
  1198.   BitMsg.Height := Msg.Height;
  1199.   OldColor:=Color;
  1200.   Color:=MsgBkGrnd;
  1201.  
  1202.   with BitMsg.Canvas do begin
  1203.     Brush.Color := MsgBkGrnd;
  1204.     Font := Msg.Font;
  1205.     TextOut(0,0,Msg.Caption);
  1206.   end;
  1207.  
  1208.    Msg.Free;
  1209.    Msg := nil;
  1210.    MessageRunning:=True;
  1211. end;
  1212. {------------------------------------------------------------------------}
  1213.  
  1214. Function TDBMultiImage.CreateMessage : Boolean;
  1215. begin
  1216.  Result:=False;
  1217.  Application.CreateForm(TSetupMsg, SetupMsg );
  1218.  SetupMsg.ShowModal;
  1219.  if SetupMsg.ModalResult = mrOK then begin
  1220.   Result:=SaveMessageToStream(SetupMsg.MessageFont,
  1221.                               SetupMsg.MessageSpeed,
  1222.                               SetupMsg.MessageColor,
  1223.                               SetupMsg.MessageMsg);
  1224.  end;
  1225.  SetupMsg.destroy;
  1226.  SetupMsg:=Nil;
  1227. end;
  1228. {------------------------------------------------------------------------}
  1229.  
  1230. Procedure TDBMultiImage.FreeMsg;
  1231. Begin
  1232.   Picture.Assign(nil);
  1233.   Color:=OldColor;
  1234.   MessageRunning:=False;
  1235. end;
  1236. {------------------------------------------------------------------------}
  1237.  
  1238. Function TDBMultiImage.Delay(Ms : Integer) : boolean;
  1239. Begin
  1240.  Inc(DelayCounter);
  1241.  if DelayCounter > MS then begin
  1242.   DelayCounter:=0;
  1243.   Result:=true;
  1244.  end else
  1245.   Result:=false;
  1246. end;
  1247. {------------------------------------------------------------------------}
  1248.  
  1249. Procedure TDBMultiImage.MoveMsg(Var WinMsg : TMessage);
  1250. Begin
  1251.   if Not MessageRunning then exit;
  1252.   if Not Delay(MsgSpeed)then exit;
  1253.   Dec(SMessageLeft,1);
  1254.   Dec(SMessageRight,1);
  1255.   Inc(MmsgCount,1);
  1256.   if SMessageRight < 0 then begin
  1257.     SMessageLeft := ScreenWd;
  1258.     SMessageRight := SMessageLeft + BitWidth;
  1259.   end;
  1260.     with Canvas do
  1261.        Draw(SMessageLeft,SMessageTop,BitMsg);
  1262. end;
  1263. {------------------------------------------------------------------------}
  1264.  
  1265. Procedure TDBMultiImage.Trigger;
  1266. Begin
  1267.   if SetupMsg <> nil then SetupMsg.Trigger;
  1268.     if (visible) and (enabled) then
  1269.    PostMessage(Handle, WM_Trigger, 0, 0);
  1270. End;
  1271. {------------------------------------------------------------------------}
  1272.  
  1273. Function TDBMultiImage.SaveMessageToStream(MFont  : Tfont;
  1274.                                            Mspeed : integer;
  1275.                                            MColor : Tcolor;
  1276.                                            MMsg   : String) : Boolean;
  1277. var
  1278.    Stream       :  TMemoryStream;
  1279.    Cursor       :  hCursor;
  1280.    Usize        :  longInt;
  1281.    P            :  Array[0..1602] of char;
  1282. begin
  1283.   Result:=True;
  1284.   if FDataLink.Field is TBlobField then begin
  1285.      If Length(MMsg) < 1 then
  1286.       begin
  1287.         Result:=False;
  1288.         exit;
  1289.        end;
  1290.  
  1291.       Usize:=WriteMessageToStream(MFont, MSpeed, MColor, MMsg, P);
  1292.  
  1293.       If Usize < 1 then
  1294.        begin
  1295.         Result:=False;
  1296.         exit;
  1297.        end;
  1298.  
  1299.       Stream:=TMemoryStream.Create;
  1300.       Stream.Write(P,Usize+1);
  1301.  
  1302.       try
  1303.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  1304.       finally
  1305.         Stream.Free;
  1306.       end;
  1307.      GetInfoAndType;
  1308.    end;
  1309. end;
  1310.  
  1311. {------------------------------------------------------------------------
  1312. Printing Stuff
  1313. ------------------------------------------------------------------------}
  1314.  
  1315. procedure TDBMultiImage.PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  1316. begin
  1317.  if Picture.Graphic.Empty then exit;
  1318.  
  1319.  if (BFiletype = 'ICO') or (BFiletype = 'WMF') then
  1320.    PrintICOWMF(X, Y, pWidth, pHeight)
  1321.  else
  1322.    PrintBitMap(X, Y, pWidth, pHeight)
  1323. end;
  1324. {---------------------------------------------------------------------}
  1325.  
  1326. procedure TDBMultiImage.PrintBitMap(X, Y, pWidth, pHeight: Integer);
  1327. var
  1328.   Info     : PBitmapInfo;
  1329.   InfoSize : Integer;
  1330.   Image    : Pointer;
  1331.   ImageSize: Longint;
  1332. begin
  1333.    if (pWidth < 1) or (pHeight < 1) then begin
  1334.       pWidth:=Picture.Bitmap.Width;
  1335.       pHeight:=Picture.Bitmap.Height;
  1336.    end;
  1337.  
  1338.    Printer.Begindoc;
  1339.  
  1340.     with Picture.Bitmap do begin
  1341.       GetDIBSizes(Handle, InfoSize, ImageSize);
  1342.       Info := MemAlloc(InfoSize);
  1343.       try
  1344.         Image := MemAlloc(ImageSize);
  1345.         try
  1346.           GetDIB(Handle, Palette, Info^, Image^);
  1347.           with Info^.bmiHeader do
  1348.            StretchDIBits(Printer.Canvas.Handle, X, Y, pWidth,
  1349.             pHeight, 0, 0, biWidth, biHeight, Image, Info^,
  1350.             DIB_RGB_COLORS, SRCCOPY)
  1351.          finally
  1352.           FreeMem(Image, ImageSize);
  1353.          end;
  1354.       finally
  1355.        FreeMem(Info, InfoSize);
  1356.       end;
  1357.     end;
  1358.     Printer.Enddoc;
  1359.   end;
  1360. {---------------------------------------------------------------------}
  1361.  
  1362. procedure TDBMultiImage.PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  1363. begin
  1364.    if (pWidth < 1) or (pHeight < 1) then begin
  1365.     pWidth:=Picture.Graphic.Width;
  1366.     pHeight:=Picture.Graphic.Height;
  1367.    end;
  1368.  
  1369.    Printer.Begindoc;
  1370.  
  1371.    Printer.Canvas.StretchDraw(Rect(X, Y, pWidth, pHeight), Picture.Graphic);
  1372.  
  1373.    Printer.Enddoc;
  1374. end;
  1375. {------------------------------------------------------------------------
  1376.  end TDBMultiImage
  1377. ------------------------------------------------------------------------}
  1378.  
  1379.  
  1380.  
  1381. {TDBMultiMedia}
  1382.  
  1383. constructor TDBMultiMedia.Create(AOwner: TComponent);
  1384. begin
  1385.   inherited Create(AOwner);
  1386.   ControlStyle := ControlStyle + [csFramed, csOpaque];
  1387.   Width := 105;
  1388.   Height := 105;
  1389.   TabStop := True;
  1390.   ParentColor := False;
  1391.   FPicture := TPicture.Create;
  1392.   FPicture.OnChange := PictureChanged;
  1393.   FBorderStyle := bsSingle;
  1394.   FAutoDisplay := True;
  1395.   FCenter := True;
  1396.   FUpdateAsJpeg := True;
  1397.   Fdither:=4;
  1398.   FResolution:=8;
  1399.   FSaveQuality:=25;
  1400.   FSaveSmooth:=0;
  1401.   FDataLink := TFieldDataLink.Create;
  1402.   FDataLink.Control := Self;
  1403.   FDataLink.OnDataChange := DataChange;
  1404.   FDataLink.OnUpdateData := UpdateData;
  1405.   FMOVTempFile:='$$$.MOV';
  1406.   FMPGTempFile:='$$$.MPG';
  1407.   FAVITempFile:='$$$.AVI';
  1408.   FWAVTempFile:='$$$.WAV';
  1409.   FMIDTempFile:='$$$.MID';
  1410.   FRMITempFile:='$$$.RMI';
  1411.   FTempFilePath:='C:\';
  1412.   MsgFont:=TFont.Create;
  1413.   BitMsg := TBitmap.Create;
  1414.   MessageRunning:=False;
  1415.   SetupMsg:=Nil;
  1416.   DelayCounter:=0;
  1417.   OldColor:=Color;
  1418. end;
  1419. {------------------------------------------------------------------------}
  1420.  
  1421. destructor TDBMultiMedia.Destroy;
  1422. begin
  1423.   CleanUpMultiMedia;
  1424.   FPicture.Free;
  1425.   FDataLink.Free;
  1426.   MsgFont.Free;
  1427.   BitMsg.Free;
  1428.   FDataLink := nil;
  1429.   inherited Destroy;
  1430. end;
  1431. {------------------------------------------------------------------------}
  1432.  
  1433. function TDBMultiMedia.GetDataSource: TDataSource;
  1434. begin
  1435.   Result := FDataLink.DataSource;
  1436. end;
  1437. {------------------------------------------------------------------------}
  1438.  
  1439. procedure TDBMultiMedia.SetDataSource(Value: TDataSource);
  1440. begin
  1441.   FDataLink.DataSource := Value;
  1442. end;
  1443. {------------------------------------------------------------------------}
  1444.  
  1445. function TDBMultiMedia.GetDataField: string;
  1446. begin
  1447.   Result := FDataLink.FieldName;
  1448. end;
  1449. {------------------------------------------------------------------------}
  1450.  
  1451. procedure TDBMultiMedia.SetDataField(const Value: string);
  1452. begin
  1453.   FDataLink.FieldName := Value;
  1454. end;
  1455. {------------------------------------------------------------------------}
  1456.  
  1457. function TDBMultiMedia.GetReadOnly: Boolean;
  1458. begin
  1459.   Result := FDataLink.ReadOnly;
  1460. end;
  1461. {------------------------------------------------------------------------}
  1462.  
  1463. procedure TDBMultiMedia.SetReadOnly(Value: Boolean);
  1464. begin
  1465.   FDataLink.ReadOnly := Value;
  1466. end;
  1467. {------------------------------------------------------------------------}
  1468.  
  1469. function TDBMultiMedia.GetField: TField;
  1470. begin
  1471.   Result := FDataLink.Field;
  1472. end;
  1473. {------------------------------------------------------------------------}
  1474.  
  1475. function TDBMultiMedia.GetPalette: HPALETTE;
  1476. begin
  1477.   Result := 0;
  1478.   if FPicture.Graphic is TBitmap then
  1479.     Result := TBitmap(FPicture.Graphic).Palette;
  1480. end;
  1481. {------------------------------------------------------------------------}
  1482.  
  1483. procedure TDBMultiMedia.SetAutoDisplay(Value: Boolean);
  1484. begin
  1485.   if FAutoDisplay <> Value then
  1486.   begin
  1487.     FAutoDisplay := Value;
  1488.     if Value then LoadMedia;
  1489.   end;
  1490. end;
  1491. {------------------------------------------------------------------------}
  1492.  
  1493. procedure TDBMultiMedia.SetBorderStyle(Value: TBorderStyle);
  1494. begin
  1495.   if FBorderStyle <> Value then
  1496.   begin
  1497.     FBorderStyle := Value;
  1498.     RecreateWnd;
  1499.   end;
  1500. end;
  1501. {------------------------------------------------------------------------}
  1502.  
  1503. procedure TDBMultiMedia.SetCenter(Value: Boolean);
  1504. begin
  1505.   if FCenter <> Value then
  1506.   begin
  1507.     FCenter := Value;
  1508.     Invalidate;
  1509.   end;
  1510. end;
  1511. {------------------------------------------------------------------------}
  1512.  
  1513. procedure TDBMultiMedia.SetPicture(Value: TPicture);
  1514. begin
  1515.   FPicture.Assign(Value);
  1516. end;
  1517. {------------------------------------------------------------------------}
  1518.  
  1519. procedure TDBMultiMedia.SetStretch(Value: Boolean);
  1520. begin
  1521.   if FStretch <> Value then
  1522.   begin
  1523.     FStretch := Value;
  1524.     Invalidate;
  1525.   end;
  1526. end;
  1527. {------------------------------------------------------------------------}
  1528.  
  1529. procedure TDBMultiMedia.Paint;
  1530. var
  1531.   W, H: Integer;
  1532.   R: TRect;
  1533.   S: string[63];
  1534. begin
  1535.   with Canvas do
  1536.   begin
  1537.     Brush.Style := bsSolid;
  1538.     Brush.Color := Color;
  1539.     if FPictureLoaded then
  1540.     begin
  1541.       if (Stretch) and (Picture.Graphic <> nil) then
  1542.         if Picture.Graphic.Empty then
  1543.           FillRect(ClientRect) else
  1544.           StretchDraw(ClientRect, Picture.Graphic)
  1545.       else
  1546.       begin
  1547.         SetRect(R, 0, 0, Picture.Width, Picture.Height);
  1548.         if Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  1549.           (ClientHeight - Picture.Height) div 2);
  1550.         StretchDraw(R, Picture.Graphic);
  1551.         ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  1552.         FillRect(ClientRect);
  1553.         SelectClipRgn(Handle, 0);
  1554.       end;
  1555.     end else
  1556.     begin
  1557.       Font := Self.Font;
  1558.       if FDataLink.Field <> nil then
  1559.         S := FDataLink.Field.DisplayLabel else
  1560.         S := Name;
  1561.       S := '(' + S + ')';
  1562.       W := TextWidth(S);
  1563.       H := TextHeight(S);
  1564.       R := ClientRect;
  1565.       TextRect(R, (R.Right - W) div 2, (R.Bottom - H) div 2, S);
  1566.     end;
  1567.     if (GetParentForm(Self).ActiveControl = Self) and
  1568.       not (csDesigning in ComponentState) then
  1569.     begin
  1570.       Brush.Color := clWindowFrame;
  1571.       FrameRect(ClientRect);
  1572.     end;
  1573.   end;
  1574. end;
  1575.  
  1576. {------------------------------------------------------------------------}
  1577.  
  1578. procedure TDBMultiMedia.PictureChanged(Sender: TObject);
  1579. begin
  1580.   FDataLink.Modified;
  1581.   FPictureLoaded := True;
  1582.   Invalidate;
  1583. end;
  1584. {------------------------------------------------------------------------}
  1585.  
  1586. procedure TDBMultiMedia.Notification(AComponent: TComponent;
  1587.   Operation: TOperation);
  1588. begin
  1589.   inherited Notification(AComponent, Operation);
  1590.   if (Operation = opRemove) and (FDataLink <> nil) and
  1591.     (AComponent = DataSource) then DataSource := nil;
  1592.  
  1593.   if (Operation = opRemove) and
  1594.     (AComponent = FMediaPlayer) then FMediaPlayer := nil;
  1595. end;
  1596. {------------------------------------------------------------------------}
  1597.  
  1598. Procedure TDBMultiMedia.CleanUpMultiMedia;
  1599. begin
  1600.    if (csDesigning in ComponentState) then exit;
  1601.    deletefile(FTempFilePath+FMPGTempFile);
  1602.    deletefile(FTempFilePath+FMOVTempFile);
  1603.    deletefile(FTempFilePath+FAVITempFile);
  1604.    deletefile(FTempFilePath+FWAVTempFile);
  1605.    deletefile(FTempFilePath+FMIDTempFile);
  1606.    deletefile(FTempFilePath+FRMITempFile);
  1607. end;
  1608.  
  1609.  
  1610. procedure TDBMultiMedia.LoadMedia;
  1611. var
  1612.    Stream       :  TMemoryStream;
  1613.    BitMap       :  TBitMap;
  1614.    Cursor       :  hCursor;
  1615.    temp         :  string;
  1616. begin
  1617.   if not FPictureLoaded and (FDataLink.Field is TBlobField) then begin
  1618.  
  1619.    if TBlobField(FDataLink.Field).IsNull then exit;
  1620.  
  1621.    Temp:=GetInfoAndType;
  1622.  
  1623.    if FMediaPlayer <> nil then
  1624.      FMediaPlayer.Close;
  1625.  
  1626.    CleanUpMultiMedia;
  1627.  
  1628.  
  1629.   if Temp = 'SCM' then begin
  1630.       Stream:=TMemoryStream.Create;
  1631.       try
  1632.        if FMediaPlayer <> nil then
  1633.          if FAutoMMHide then
  1634.            FMediaPlayer.Visible:=False;
  1635.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1636.          FreeMsg;
  1637.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  1638.          LoadMessageFromStream(Stream);
  1639.          KillTimer(handle,1);
  1640.          if @TDBMultiMediaCallBack <> nil then
  1641.            TDBMultiMediaCallBack(0);
  1642.        finally
  1643.          SetCursor(Cursor);
  1644.          Stream.Free;
  1645.        end;
  1646.    end else
  1647.  
  1648.   if Temp = 'MPG' then begin
  1649.          try
  1650.             if (csDesigning in ComponentState) then exit;
  1651.  
  1652.             if not IsValidMultiMedia('MPG') then exit;
  1653.               Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1654.               FreeMsg;
  1655.               if FMediaPlayer <> nil then begin
  1656.                FMediaPlayer.Visible:=true;
  1657.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FMPGTempFile);
  1658.                FMediaPlayer.FileName:=FTempFilePath+FMPGTempFile;
  1659.                FMediaPlayer.Open;
  1660.                if FAutoPlayMM then
  1661.                  FMediaPlayer.Play;
  1662.                SetTimer(handle,1,500,nil);
  1663.             end;
  1664.          finally
  1665.             SetCursor(Cursor);
  1666.          end;
  1667.    end else
  1668.  
  1669.    if Temp = 'MOV' then begin
  1670.          try
  1671.             if (csDesigning in ComponentState) then exit;
  1672.  
  1673.             if not IsValidMultiMedia('MOV') then exit;
  1674.               Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1675.               FreeMsg;
  1676.               if FMediaPlayer <> nil then begin
  1677.                FMediaPlayer.Visible:=true;
  1678.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FMOVTempFile);
  1679.                FMediaPlayer.FileName:=FTempFilePath+FMOVTempFile;
  1680.                FMediaPlayer.Open;
  1681.                if FAutoPlayMM then
  1682.                  FMediaPlayer.Play;
  1683.                SetTimer(handle,1,500,nil);
  1684.             end;
  1685.          finally
  1686.             SetCursor(Cursor);
  1687.          end;
  1688.    end else
  1689.  
  1690.    if Temp = 'AVI' then begin
  1691.          try
  1692.             if (csDesigning in ComponentState) then exit;
  1693.  
  1694.             if not IsValidMultiMedia('AVI') then exit;
  1695.               Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1696.               FreeMsg;
  1697.               if FMediaPlayer <> nil then begin
  1698.                FMediaPlayer.Visible:=true;
  1699.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FAVITempFile);
  1700.                FMediaPlayer.FileName:=FTempFilePath+FAVITempFile;
  1701.                FMediaPlayer.Open;
  1702.                if FAutoPlayMM then
  1703.                  FMediaPlayer.Play;
  1704.                SetTimer(handle,1,500,nil);
  1705.             end;
  1706.          finally
  1707.             SetCursor(Cursor);
  1708.          end;
  1709.    end else
  1710.  
  1711.    if Temp = 'WAV' then begin
  1712.          try
  1713.             if (csDesigning in ComponentState) then exit;
  1714.  
  1715.             if not IsValidMultiMedia('WAV') then exit;
  1716.              Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1717.              FreeMsg;
  1718.              if FMediaPlayer <> nil then begin
  1719.                FMediaPlayer.Visible:=true;
  1720.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FWAVTempFile);
  1721.                FMediaPlayer.FileName:=FTempFilePath+FWAVTempFile;
  1722.                FMediaPlayer.Open;
  1723.                if FAutoPlayMM then
  1724.                  FMediaPlayer.Play;
  1725.                SetTimer(handle,1,500,nil);
  1726.             end;
  1727.          finally
  1728.             SetCursor(Cursor);
  1729.          end;
  1730.    end else
  1731.  
  1732.    if Temp = 'MID' then begin
  1733.          try
  1734.             if (csDesigning in ComponentState) then exit;
  1735.  
  1736.             if not IsValidMultiMedia('MID') then exit;
  1737.              Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1738.              FreeMsg;
  1739.              if FMediaPlayer <> nil then begin
  1740.                FMediaPlayer.Visible:=true;
  1741.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FMIDTempFile);
  1742.                FMediaPlayer.FileName:=FTempFilePath+FMIDTempFile;
  1743.                FMediaPlayer.Open;
  1744.                if FAutoPlayMM then
  1745.                  FMediaPlayer.Play;
  1746.                SetTimer(handle,1,500,nil);
  1747.             end;
  1748.          finally
  1749.             SetCursor(Cursor);
  1750.          end;
  1751.    end else
  1752.  
  1753.    if Temp = 'RMI' then begin
  1754.          try
  1755.             if (csDesigning in ComponentState) then exit;
  1756.  
  1757.             if not IsValidMultiMedia('RMI') then exit;
  1758.             Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1759.             FreeMsg;
  1760.             if FMediaPlayer <> nil then begin
  1761.                FMediaPlayer.Visible:=true;
  1762.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FRMITempFile);
  1763.                FMediaPlayer.FileName:=FTempFilePath+FRMITempFile;
  1764.                FMediaPlayer.Open;
  1765.                if FAutoPlayMM then
  1766.                  FMediaPlayer.Play;
  1767.                SetTimer(handle,1,500,nil);
  1768.             end;
  1769.          finally
  1770.             SetCursor(Cursor);
  1771.          end;
  1772.    end else
  1773.  
  1774.    if Temp = 'GIF' then begin
  1775.       Stream:=TMemoryStream.Create;
  1776.       BitMap:=TBitMap.Create;
  1777.       try
  1778.        if FMediaPlayer <> nil then
  1779.          if FAutoMMHide then
  1780.            FMediaPlayer.Visible:=False;
  1781.          KillTimer(handle,1);
  1782.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1783.          FreeMsg;
  1784.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  1785.          if not gifblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiMediaCallBack) then begin
  1786.             MessageDlg('Invallid or empty GIF blobfield', mtInformation, [mbOk], 0);
  1787.             Picture.Assign(Nil);
  1788.          end else
  1789.             Picture.Assign(BitMap);
  1790.          finally
  1791.             SetCursor(Cursor);
  1792.             BitMap.free;
  1793.             Stream.Free;
  1794.          end;
  1795.    end else
  1796.  
  1797.    if Temp = 'PCX' then begin
  1798.       Stream:=TMemoryStream.Create;
  1799.       BitMap:=TBitMap.Create;
  1800.       try
  1801.        if FMediaPlayer <> nil then
  1802.          if FAutoMMHide then
  1803.            FMediaPlayer.Visible:=False;
  1804.          KillTimer(handle,1);
  1805.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1806.          FreeMsg;
  1807.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  1808.          if not pcxblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiMediaCallBack) then begin
  1809.             MessageDlg('Invallid or empty PCX blobfield', mtInformation, [mbOk], 0);
  1810.             Picture.Assign(Nil);
  1811.          end else
  1812.             Picture.Assign(BitMap);
  1813.          finally
  1814.           SetCursor(Cursor);
  1815.           BitMap.free;
  1816.           Stream.Free;
  1817.          end;
  1818.    end else
  1819.  
  1820.    if Temp = 'BMP' then begin
  1821.       Stream:=TMemoryStream.Create;
  1822.       BitMap:=TBitMap.Create;
  1823.       try
  1824.        if FMediaPlayer <> nil then
  1825.          if FAutoMMHide then
  1826.            FMediaPlayer.Visible:=False;
  1827.          KillTimer(handle,1);
  1828.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1829.          FreeMsg;
  1830.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  1831.          if not bmpblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiMediaCallBack) then begin
  1832.             MessageDlg('Invallid or empty BMP blobfield', mtInformation, [mbOk], 0);
  1833.             Picture.Assign(Nil);
  1834.          end else
  1835.             Picture.Assign(BitMap);
  1836.          finally
  1837.           SetCursor(Cursor);
  1838.           BitMap.free;
  1839.           Stream.Free;
  1840.          end;
  1841.    end else
  1842.  
  1843.    if Temp = 'JPG' then begin
  1844.       Stream:=TMemoryStream.Create;
  1845.       BitMap:=TBitMap.Create;
  1846.       if FResolution <> 4 then
  1847.       if FResolution <> 8 then
  1848.       if FResolution <> 24 then FResolution:=8;
  1849.       if (FDither < 0) or (FDither > 4) then FDither:=4;
  1850.       try
  1851.        if FMediaPlayer <> nil then
  1852.          if FAutoMMHide then
  1853.            FMediaPlayer.Visible:=False;
  1854.          KillTimer(handle,1);
  1855.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1856.          FreeMsg;
  1857.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  1858.          if not jpgblob(Stream.Memory,Stream.Size, FResolution, Fdither, Bitmap, TDBMultiMediaCallBack) then begin
  1859.             MessageDlg('Invallid or empty Jpeg Blobfield', mtInformation, [mbOk], 0);
  1860.             Picture.Assign(Nil);
  1861.          end else
  1862.              Picture.Assign(BitMap);
  1863.          finally
  1864.              SetCursor(Cursor);
  1865.              BitMap.free;
  1866.              Stream.Free;
  1867.          end;
  1868.     end else
  1869.      KillTimer(handle,1);
  1870.     {GetInfoAndType;}
  1871.  end;
  1872. end;
  1873. {------------------------------------------------------------------------}
  1874.  
  1875. procedure TDBMultiMedia.DataChange(Sender: TObject);
  1876. begin
  1877.   Picture.Graphic := nil;
  1878.   FPictureLoaded := False;
  1879.   if FAutoDisplay then LoadMedia;
  1880. end;
  1881. {------------------------------------------------------------------------}
  1882.  
  1883. procedure TDBMultiMedia.UpdateData(Sender: TObject);
  1884. var
  1885.    Stream       :  TMemoryStream;
  1886.    Cursor       :  hCursor;
  1887.    Usize        :  longInt;
  1888.    x,y          :  longInt;
  1889.    p            :  Pointer;
  1890. begin
  1891.   if FDataLink.Field is TBlobField then begin
  1892.  
  1893.     if Picture.Graphic is TBitmap then begin
  1894.       x:=Picture.BitMap.Width;
  1895.       y:=Picture.BitMap.Height;
  1896.  
  1897.       y:=y+(y div 5);
  1898.       x:=x+(x div 5);
  1899.  
  1900.       Usize:=(y * x);
  1901.  
  1902.       if Usize < 90000 then Usize:=Usize*2;
  1903.  
  1904.       {Since we can't know how much memory we need to allocate
  1905.       to write the picture to the stream we need to guess it. This
  1906.       is done using the width and height of the bitmap. After the call
  1907.       to the dll using PUTJPGBLOB or PUTBMPBLOB Usize contains the
  1908.       correct size of the Bitmap stored in P^. You can increase or decrease
  1909.       the guessed memory by altering the Div by. For instance
  1910.  
  1911.       y:=y+(y div 3);
  1912.       x:=x+(x div 3);
  1913.  
  1914.       will allocate more memory then
  1915.  
  1916.       y:=y+(y div 6);
  1917.       x:=x+(x div 6);
  1918.  
  1919.       We played it on the save side. Use this "guess work" very carefully}
  1920.  
  1921.  
  1922.       P := GlobalAllocPtr(HeapAllocFlags, Usize);
  1923.       if P = Nil then begin
  1924.         MessageDlg('Error allocation blob memory', mtInformation, [mbOk], 0);
  1925.         exit;
  1926.       end;
  1927.  
  1928.       if FUpdateAsJpeg then begin
  1929.          if not putjpgblob(P, USize, FSaveQuality, FSaveSmooth, Picture.Bitmap, TDBMultiMediaCallBack) then
  1930.            MessageDlg('Jpeg BLOB Write Error', mtInformation, [mbOk], 0);
  1931.       end else begin
  1932.          if not putbmpblob(P, USize, Picture.Bitmap, TDBMultiMediaCallBack) then
  1933.            MessageDlg('BMP BLOB Write Error', mtInformation, [mbOk], 0);
  1934.       end;
  1935.  
  1936.       Stream:=TMemoryStream.Create;
  1937.       Stream.Write(P^,USize);
  1938.       GlobalFreePtr(P);
  1939.  
  1940.       try
  1941.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  1942.       finally
  1943.         Stream.Free;
  1944.       end;
  1945.  
  1946.     end else
  1947.       TBlobField(FDataLink.Field).Clear;
  1948.    end;
  1949.    GetInfoAndType;
  1950. end;
  1951. {------------------------------------------------------------------------}
  1952.  
  1953. procedure TDBMultiMedia.CopyToClipboard;
  1954. begin
  1955.   if Picture.Graphic <> nil then Clipboard.Assign(Picture);
  1956. end;
  1957. {------------------------------------------------------------------------}
  1958.  
  1959. procedure TDBMultiMedia.CutToClipboard;
  1960. begin
  1961.   if Picture.Graphic <> nil then
  1962.   begin
  1963.     CopyToClipboard;
  1964.     if FDataLink.Edit then
  1965.       Picture.Graphic := nil;
  1966.   end;
  1967. end;
  1968. {------------------------------------------------------------------------}
  1969.  
  1970. procedure TDBMultiMedia.PasteFromClipboard;
  1971. begin
  1972.   if Clipboard.HasFormat(CF_PICTURE) and FDataLink.Edit then begin
  1973.     MessageRunning:=False;
  1974.     Picture.Assign(Clipboard);
  1975.    end;
  1976. end;
  1977. {------------------------------------------------------------------------}
  1978.  
  1979. procedure TDBMultiMedia.CreateParams(var Params: TCreateParams);
  1980. begin
  1981.   inherited CreateParams(Params);
  1982.   if FBorderStyle = bsSingle then
  1983.     Params.Style := Params.Style or WS_BORDER;
  1984. end;
  1985. {------------------------------------------------------------------------}
  1986.  
  1987. procedure TDBMultiMedia.KeyDown(var Key: Word; Shift: TShiftState);
  1988. begin
  1989.   inherited KeyDown(Key, Shift);
  1990.   case Key of
  1991.     VK_INSERT:
  1992.       if ssShift in Shift then PasteFromClipBoard else
  1993.         if ssCtrl in Shift then CopyToClipBoard;
  1994.     VK_DELETE:
  1995.       if ssShift in Shift then CutToClipBoard;
  1996.   end;
  1997. end;
  1998. {------------------------------------------------------------------------}
  1999.  
  2000. procedure TDBMultiMedia.KeyPress(var Key: Char);
  2001. begin
  2002.   inherited KeyPress(Key);
  2003.   case Key of
  2004.     ^X: CutToClipBoard;
  2005.     ^C: CopyToClipBoard;
  2006.     ^V: PasteFromClipBoard;
  2007.     #13: LoadMedia;
  2008.     #27: FDataLink.Reset;
  2009.   end;
  2010. end;
  2011. {------------------------------------------------------------------------}
  2012.  
  2013. procedure TDBMultiMedia.CMEnter(var Message: TCMEnter);
  2014. begin
  2015.   Invalidate; { Draw the focus marker }
  2016.   inherited;
  2017. end;
  2018. {------------------------------------------------------------------------}
  2019.  
  2020. procedure TDBMultiMedia.CMExit(var Message: TCMExit);
  2021. begin
  2022.   Invalidate; { Erase the focus marker }
  2023.   inherited;
  2024. end;
  2025. {------------------------------------------------------------------------}
  2026.  
  2027. procedure TDBMultiMedia.CMTextChanged(var Message: TMessage);
  2028. begin
  2029.   inherited;
  2030.   if not FPictureLoaded then Invalidate;
  2031. end;
  2032. {------------------------------------------------------------------------}
  2033.  
  2034. procedure TDBMultiMedia.WMLButtonDown(var Message: TWMLButtonDown);
  2035. begin
  2036.   if TabStop and CanFocus then SetFocus;
  2037.   inherited;
  2038. end;
  2039. {------------------------------------------------------------------------}
  2040.  
  2041. procedure TDBMultiMedia.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  2042. begin
  2043.   LoadMedia;
  2044.   inherited;
  2045. end;
  2046. {------------------------------------------------------------------------}
  2047.  
  2048. procedure TDBMultiMedia.WMCut(var Message: TMessage);
  2049. begin
  2050.   CutToClipboard;
  2051. end;
  2052. {------------------------------------------------------------------------}
  2053.  
  2054. procedure TDBMultiMedia.WMCopy(var Message: TMessage);
  2055. begin
  2056.   CopyToClipboard;
  2057. end;
  2058. {------------------------------------------------------------------------}
  2059.  
  2060. procedure TDBMultiMedia.WMPaste(var Message: TMessage);
  2061. begin
  2062.   PasteFromClipboard;
  2063. end;
  2064. {------------------------------------------------------------------------}
  2065.  
  2066. procedure TDBMultiMedia.LoadFromFile(filename : TFilename);
  2067. var
  2068.    Cursor       :  hCursor;
  2069. begin
  2070.  
  2071.   if not FileExists(filename) then begin
  2072.     MessageDlg('File not found', mtInformation, [mbOk], 0);
  2073.     exit;
  2074.   end;
  2075.  
  2076.   if UpperCase(ExtractFileExt(filename)) <> '.JPG' then
  2077.   if UpperCase(ExtractFileExt(filename)) <> '.GIF' then
  2078.   if UpperCase(ExtractFileExt(filename)) <> '.PCX' then
  2079.   if UpperCase(ExtractFileExt(filename)) <> '.BMP' then
  2080.   if UpperCase(ExtractFileExt(filename)) <> '.WAV' then
  2081.   if UpperCase(ExtractFileExt(filename)) <> '.AVI' then
  2082.   if UpperCase(ExtractFileExt(filename)) <> '.MOV' then
  2083.   if UpperCase(ExtractFileExt(filename)) <> '.MID' then
  2084.   if UpperCase(ExtractFileExt(filename)) <> '.RMI' then
  2085.   if UpperCase(ExtractFileExt(filename)) <> '.SCM' then
  2086.   {if UpperCase(ExtractFileExt(filename)) <> '.MPG' then}
  2087.   begin
  2088.     MessageDlg('A None Supported File Format', mtInformation, [mbOk], 0);
  2089.     exit;
  2090.   end;
  2091.  
  2092.   if FDataLink.Field is TBlobField then begin
  2093.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2094.     TBlobField(FDataLink.Field).LoadFromFile(filename);
  2095.     SetCursor(Cursor);
  2096.   end else begin
  2097.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  2098.     exit;
  2099.   end;
  2100.   {GetInfoAndType;}
  2101.   SetCursor(Cursor);
  2102. end;
  2103. {------------------------------------------------------------------------}
  2104.  
  2105. procedure TDBMultiMedia.SaveToFile(filename : TFilename);
  2106. var
  2107.   Cursor       :  hCursor;
  2108. begin
  2109.   if FDataLink.Field is TBlobField then begin
  2110.  
  2111.     if TBlobField(FDataLink.Field).IsNull then begin
  2112.        MessageDlg('Can''t save, blobfield is empty', mtInformation, [mbOk], 0);
  2113.        exit;
  2114.     end;
  2115.  
  2116.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2117.     TBlobField(FDataLink.Field).SaveToFile(filename);
  2118.     GetInfoAndType;
  2119.     SetCursor(Cursor)
  2120.  
  2121.   end else begin
  2122.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  2123.     exit;
  2124.   end;
  2125. end;
  2126. {------------------------------------------------------------------------}
  2127.  
  2128. procedure TDBMultiMedia.SaveToFileAsBMP(filename : TFilename);
  2129. var
  2130.   Cursor       :  hCursor;
  2131. begin
  2132.   if FDataLink.Field is TBlobField then begin
  2133.  
  2134.     if TBlobField(FDataLink.Field).IsNull then begin
  2135.        MessageDlg('Can''t save, blobfield bitmap is empty', mtInformation, [mbOk], 0);
  2136.        exit;
  2137.     end;
  2138.  
  2139.     if picture.bitmap.empty then begin
  2140.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  2141.                   mtInformation, [mbOk], 0);
  2142.        exit;
  2143.     end;
  2144.  
  2145.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2146.  
  2147.     if not putbmpfile(FileName, picture.Bitmap, TDBMultiMediaCallBack) then begin
  2148.       SetCursor(Cursor);
  2149.       MessageDlg('Writing bmp file failed', mtInformation, [mbOk], 0);
  2150.       exit;
  2151.     end;
  2152.  
  2153.     GetInfoAndType
  2154.  
  2155.   end else begin
  2156.     SetCursor(Cursor);
  2157.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  2158.     exit;
  2159.   end;
  2160.  
  2161.   SetCursor(Cursor);
  2162. end;
  2163. {------------------------------------------------------------------------}
  2164.  
  2165. procedure TDBMultiMedia.SaveToFileAsJpeg(filename : TFilename);
  2166. var
  2167.   Cursor       :  hCursor;
  2168. begin
  2169.   if FDataLink.Field is TBlobField then begin
  2170.  
  2171.     if TBlobField(FDataLink.Field).IsNull then begin
  2172.        MessageDlg('Can''t save, blobfield bitmap is empty', mtInformation, [mbOk], 0);
  2173.        exit;
  2174.     end;
  2175.  
  2176.     if picture.bitmap = nil then begin
  2177.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  2178.                   mtInformation, [mbOk], 0);
  2179.        exit;
  2180.     end;
  2181.  
  2182.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2183.  
  2184.     if not putjpgfile(FileName, FSaveQuality, FSaveSmooth, picture.Bitmap, TDBMultiMediaCallBack) then begin
  2185.       SetCursor(Cursor);
  2186.       MessageDlg('Writing jpg file failed', mtInformation, [mbOk], 0);
  2187.       exit;
  2188.     end;
  2189.  
  2190.     GetInfoAndType
  2191.  
  2192.   end else begin
  2193.     SetCursor(Cursor);
  2194.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  2195.     exit;
  2196.   end;
  2197.  
  2198.   SetCursor(Cursor);
  2199. end;
  2200. {------------------------------------------------------------------------}
  2201.  
  2202.  
  2203. function TDBMultiMedia.GetInfoAndType : String;
  2204. var
  2205.  Stream       :  TMemoryStream;
  2206.  Hdr          :  Array[0..45] of char;
  2207.  i            :  Byte;
  2208. begin
  2209.   if (FDataLink.Field is TBlobField) then
  2210.    if TBlobField(FDataLink.Field).IsNull then exit;
  2211.  
  2212.    BFileType := 'Empty';
  2213.    Bwidth:=-1;
  2214.    BHeight:=-1;
  2215.    Bbitspixel:=-1;
  2216.    Bplanes:=-1;
  2217.    Bnumcolors:=-1;
  2218.    Bcompression:='-1';
  2219.    BSize:=-1;
  2220.    GetInfoAndType :='-1';
  2221.  
  2222.    Stream:=TMemoryStream.Create;
  2223.    TBlobField(FDataLink.Field).SaveToStream(Stream);
  2224.  
  2225.    if Stream.Memory = nil then begin
  2226.      MessageDlg('Error allocation temporary blob memory', mtInformation, [mbOk], 0);
  2227.      exit;
  2228.    end;
  2229.  
  2230.    Stream.Seek(0,0);
  2231.    Stream.read(hdr,SizeOf(Hdr)-1);
  2232.  
  2233.    for i:=0 to SizeOf(hdr)-1 do
  2234.     if hdr[i] = #0 then hdr[i]:=' ';
  2235.  
  2236.    if StrPos(hdr,'RIFF') <> nil then begin
  2237.         Bwidth:=-1;
  2238.         BHeight:=-1;
  2239.         Bbitspixel:=-1;
  2240.         Bplanes:=-1;
  2241.         Bnumcolors:=-1;
  2242.         Bcompression:='RIFF';
  2243.  
  2244.      if StrPos(hdr,'WAV') <> nil then begin
  2245.         BSize:=Stream.Size;
  2246.         BFileType:= 'WAV';
  2247.         GetInfoAndType:='WAV';
  2248.      end;
  2249.  
  2250.      if StrPos(hdr,'AVI') <> nil then begin
  2251.         BSize:=Stream.Size;
  2252.         BFileType:= 'AVI';
  2253.         GetInfoAndType:='AVI';
  2254.      end;
  2255.  
  2256.      if StrPos(hdr,'RMID') <> nil then begin
  2257.         BSize:=Stream.Size;
  2258.         BFileType:= 'RMI';
  2259.         GetInfoAndType:='RMI';
  2260.      end;
  2261.  
  2262.      if Stream.Memory <> nil then Stream.Free;
  2263.      exit;
  2264.    end else
  2265.  
  2266. {   if StrPos(hdr,'mpeg') <> nil then begin
  2267.         Bwidth:=-1;
  2268.         BHeight:=-1;
  2269.         Bbitspixel:=-1;
  2270.         Bplanes:=-1;
  2271.         Bnumcolors:=-1;
  2272.         Bcompression:='MPEG';
  2273.         BSize:=Stream.Size;
  2274.         BFileType:= 'MPG';
  2275.         GetInfoAndType:='MPG';
  2276.         if Stream.Memory <> nil then Stream.Free;
  2277.         exit;
  2278.    end else}
  2279.  
  2280.    if StrPos(hdr,'mdat') <> nil then begin
  2281.         Bwidth:=-1;
  2282.         BHeight:=-1;
  2283.         Bbitspixel:=-1;
  2284.         Bplanes:=-1;
  2285.         Bnumcolors:=-1;
  2286.         Bcompression:='QTM';
  2287.         BSize:=Stream.Size;
  2288.         BFileType:= 'MOV';
  2289.         GetInfoAndType:='MOV';
  2290.         if Stream.Memory <> nil then Stream.Free;
  2291.         exit;
  2292.    end else
  2293.  
  2294.    if StrPos(hdr,'MThd') <> nil then begin
  2295.         Bwidth:=-1;
  2296.         BHeight:=-1;
  2297.         Bbitspixel:=-1;
  2298.         Bplanes:=-1;
  2299.         Bnumcolors:=-1;
  2300.         Bcompression:='MIDI';
  2301.         BSize:=Stream.Size;
  2302.         BFileType:= 'MID';
  2303.         GetInfoAndType:='MID';
  2304.         if Stream.Memory <> nil then Stream.Free;
  2305.         exit;
  2306.      end else
  2307.  
  2308.    if StrPos(hdr,'kevinjan') <> nil then begin
  2309.         Bwidth:=-1;
  2310.         BHeight:=-1;
  2311.         Bbitspixel:=-1;
  2312.         Bplanes:=-1;
  2313.         Bnumcolors:=-1;
  2314.         Bcompression:='MSG';
  2315.         BSize:=Stream.Size;
  2316.         BFileType:= 'SCM';
  2317.         GetInfoAndType:='SCM';
  2318.         if Stream.Memory <> nil then Stream.Free;
  2319.         exit;
  2320.      end else
  2321.  
  2322.  if not GetBlobInfo(Stream.Memory,
  2323.                     Stream.Size,
  2324.                     BFileType,
  2325.                     Bwidth,
  2326.                     BHeight,
  2327.                     Bbitspixel,
  2328.                     Bplanes,
  2329.                     Bnumcolors,
  2330.                     Bcompression) then
  2331.        MessageDlg('blobfield getinfo failed', mtInformation, [mbOk], 0)
  2332.     else begin
  2333.        BSize:=Stream.Size;
  2334.        if UpperCase(BFileType) = 'GIF' then GetInfoAndType:='GIF' else
  2335.        if UpperCase(BFileType) = 'PCX' then GetInfoAndType:='PCX' else
  2336.        if UpperCase(BFileType) = 'JPEG' then GetInfoAndType:='JPG' else
  2337.        if UpperCase(BFileType) = 'BMP' then GetInfoAndType:='BMP';
  2338.     end;
  2339.   if Stream.Memory <> nil then Stream.Free;
  2340. end;
  2341. {------------------------------------------------------------------------}
  2342.  
  2343. function TDBMultiMedia.GetSmooth : Byte;
  2344. begin
  2345.   GetSmooth:=FSaveSmooth;
  2346. end;
  2347. {------------------------------------------------------------------------}
  2348.  
  2349. procedure TDBMultiMedia.SetSmooth(Smooth : Byte);
  2350. begin
  2351.   if (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
  2352.    FSaveSmooth:=Smooth;
  2353. end;
  2354. {------------------------------------------------------------------------}
  2355.  
  2356. function TDBMultiMedia.GetQuality : Byte;
  2357. begin
  2358.   GetQuality:=FSaveQuality;
  2359. end;
  2360. {------------------------------------------------------------------------}
  2361.  
  2362. procedure TDBMultiMedia.SetQuality(Quality : Byte);
  2363. begin
  2364.   if (Quality > 100) or (Quality < 1) then FSaveQuality:=25 else
  2365.    FSaveQuality:=Quality;
  2366. end;
  2367. {------------------------------------------------------------------------}
  2368.  
  2369. function TDBMultiMedia.GetDither : Byte;
  2370. begin
  2371.   GetDither:=Fdither
  2372. end;
  2373. {------------------------------------------------------------------------}
  2374.  
  2375. procedure TDBMultiMedia.SetDither(dith : Byte);
  2376. begin
  2377.   Fdither:=4;
  2378.   case dith of
  2379.             0..4 :Fdither:=dith;
  2380.   end;
  2381. end;
  2382. {------------------------------------------------------------------------}
  2383.  
  2384. function TDBMultiMedia.GetRes : Byte;
  2385. begin
  2386.   GetRes:=FResolution;
  2387. end;
  2388. {------------------------------------------------------------------------}
  2389.  
  2390. function TDBMultiMedia.GetTempPath : String;
  2391. begin
  2392.   GetTempPath:=FTempFilePath;
  2393. end;
  2394. {------------------------------------------------------------------------}
  2395.  
  2396. procedure TDBMultiMedia.SetTempPath(temppath : string);
  2397. var
  2398.  temp, OldDir : string;
  2399. begin
  2400.   temp:=AddBackSlash(TempPath);
  2401.   GetDir(0,OldDir);
  2402.   try
  2403.      ChDir(temp);
  2404.   except
  2405.      temp:='C:\';
  2406.   end;
  2407.   ChDir(OldDir);
  2408.   FTempFilePath:=temp;
  2409. end;
  2410. {------------------------------------------------------------------------}
  2411.  
  2412. procedure TDBMultiMedia.SetRes(res : Byte);
  2413. begin
  2414.   FResolution:=8;
  2415.   case res of
  2416.             4 :FResolution:=res;
  2417.             8 :FResolution:=res;
  2418.             24:FResolution:=res;
  2419.   end;
  2420. end;
  2421. {------------------------------------------------------------------------}
  2422.  
  2423. function TDBMultiMedia.GetMediaPlayer: TDBMediaPlayer;
  2424. begin
  2425.  Result:=FMediaPlayer;
  2426. end;
  2427. {------------------------------------------------------------------------}
  2428.  
  2429. procedure TDBMultiMedia.SetMediaPlayer(Value: TDBMediaPlayer);
  2430. begin
  2431.   FMediaPlayer:=Value;
  2432. end;
  2433. {------------------------------------------------------------------------}
  2434.  
  2435. function TDBMultiMedia.AddBackSlash(DirName : string) : string;
  2436. const
  2437.   DosDelimSet : set of Char = ['\', ':', #0];
  2438.   begin
  2439.     if DirName[Length(DirName)] in DosDelimSet then
  2440.       AddBackSlash := DirName
  2441.     else
  2442.       AddBackSlash := DirName+'\';
  2443.   end;
  2444. {------------------------------------------------------------------------}
  2445.  
  2446. function TDBMultiMedia.IsValidMultiMedia(Name : PChar) : boolean;
  2447.  var
  2448.   temp : Array[0..25] of char;
  2449. begin
  2450.    Result:=ValidMultiMedia(Name);
  2451. end;
  2452. {------------------------------------------------------------------------}
  2453.  
  2454. function TDBMultiMedia.GetMultiMediaExtensions : String;
  2455. var
  2456.   temp : string;
  2457. begin
  2458.   temp:='All MultiMedia|*.bmp;*.gif;*.pcx;*.jpg;*.scm;';
  2459.  
  2460.   if IsValidMultiMedia('wav') then
  2461.     temp:=temp+'*.wav;';
  2462.   if IsValidMultiMedia('mid') then
  2463.     temp:=temp+'*.mid;';
  2464.   if IsValidMultiMedia('rmi') then
  2465.     temp:=temp+'*.rmi;';
  2466.   if IsValidMultiMedia('avi') then
  2467.     temp:=temp+'*.avi;';
  2468.   if IsValidMultiMedia('mov') then
  2469.     temp:=temp+'*.mov;';
  2470.  {if IsValidMultiMedia('mgp') then
  2471.     temp:=temp+'*.mpg;';}
  2472.  
  2473.   temp:=temp+'|BMP Files|*.bmp';
  2474.   temp:=temp+'|GIF Files|*.gif';
  2475.   temp:=temp+'|JPG Files|*.jpg';
  2476.   temp:=temp+'|PCX Files|*.pcx';
  2477.   temp:=temp+'|SCM Files|*.scm';
  2478.  
  2479.   if IsValidMultiMedia('wav') then
  2480.     temp:=temp+'|Wave Files|*.wav';
  2481.   if IsValidMultiMedia('mid') then
  2482.     temp:=temp+'|Midi Files|*.mid';
  2483.   if IsValidMultiMedia('rmi') then
  2484.     temp:=temp+'|RMI Files|*.rmi';
  2485.   if IsValidMultiMedia('avi') then
  2486.     temp:=temp+'|AVI Files|*.avi';
  2487.   if IsValidMultiMedia('mov') then
  2488.     temp:=temp+'|Movie Files|*.mov';
  2489.   {if IsValidMultiMedia('mgp') then
  2490.    temp:=temp+'|Mpeg Files|*.mpg';}
  2491.  
  2492.   Result:=temp;
  2493. end;
  2494. {------------------------------------------------------------------------}
  2495.  
  2496. procedure TDBMultiMedia.TimerNotify(var Message: TMessage);
  2497. var
  2498.   MPosition : integer;
  2499. begin
  2500.  if FMediaPlayer = nil then exit;
  2501.  
  2502.  if not AutoRePlayMultiMedia then
  2503.    if FMediaPlayer.Mode <> MpPlaying then exit;
  2504.  
  2505.   MPosition:=Round(FMediaPlayer.Position * (100 / FMediaPlayer.length));
  2506.  
  2507.   if @TDBMultiMediaCallBack <> nil then
  2508.    TDBMultiMediaCallBack(MPosition);
  2509.  
  2510.   if (FAutoRePlayMM) and (MPosition >= 100) and (FMediaPlayer.FileName <> '') then
  2511.    FMediaPlayer.Play;
  2512.  
  2513. end;
  2514. {------------------------------------------------------------------------
  2515.  scrolling message stuff
  2516. ------------------------------------------------------------------------}
  2517.  
  2518. procedure TDBMultiMedia.LoadMessageFromStream(MessageStream : TStream);
  2519. var
  2520.   Msg      : TLabel;
  2521. begin
  2522.   Picture.Assign(nil);
  2523.   ScreenWd:=Width;
  2524.   ScreenHt:=Height;
  2525.   Msg := TLabel.Create(Self);
  2526.   readmessagefromstream(MessageStream, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
  2527.   Refresh;
  2528.   if MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  2529.   Msg.Parent :=Self;
  2530.   Msg.Visible := False;
  2531.   Msg.Font := MsgFont;
  2532.   Msg.Caption := MsgText;
  2533.   BitWidth:=Msg.Width;
  2534.   SMessageLeft := ScreenWd;
  2535.   SMessageRight := ScreenWd + Msg.Width;
  2536.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  2537.   BitMsg.Width := Msg.Width;
  2538.   BitMsg.Height := Msg.Height;
  2539.   OldColor:=Color;
  2540.   Color:=MsgBkGrnd;
  2541.  
  2542.   with BitMsg.Canvas do begin
  2543.     Brush.Color := MsgBkGrnd;
  2544.     Font := Msg.Font;
  2545.     TextOut(0,0,Msg.Caption);
  2546.   end;
  2547.  
  2548.    Msg.Free;
  2549.    Msg := nil;
  2550.    MessageRunning:=True;
  2551. end;
  2552. {------------------------------------------------------------------------}
  2553.  
  2554. procedure TDBMultiMedia.NewMessage;
  2555. var
  2556.   Msg      : TLabel;
  2557. begin
  2558.   if MsgText = '' then exit;
  2559.   if MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  2560.   Picture.Assign(nil);
  2561.   ScreenWd:=Width;
  2562.   ScreenHt:=Height;
  2563.   Msg := TLabel.Create(Self);
  2564.   Refresh;
  2565.   Msg.Parent :=Self;
  2566.   Msg.Visible := False;
  2567.   Msg.Font := MsgFont;
  2568.   Msg.Caption := MsgText;
  2569.   BitWidth:=Msg.Width;
  2570.   SMessageLeft := ScreenWd;
  2571.   SMessageRight := ScreenWd + Msg.Width;
  2572.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  2573.   BitMsg.Width := Msg.Width;
  2574.   BitMsg.Height := Msg.Height;
  2575.   OldColor:=Color;
  2576.   Color:=MsgBkGrnd;
  2577.  
  2578.   with BitMsg.Canvas do begin
  2579.     Brush.Color := MsgBkGrnd;
  2580.     Font := Msg.Font;
  2581.     TextOut(0,0,Msg.Caption);
  2582.   end;
  2583.  
  2584.    Msg.Free;
  2585.    Msg := nil;
  2586.    MessageRunning:=True;
  2587. end;
  2588. {------------------------------------------------------------------------}
  2589.  
  2590. Function TDBMultiMedia.CreateMessage : Boolean;
  2591. begin
  2592.  Result:=False;
  2593.  
  2594.  Application.CreateForm(TSetupMsg, SetupMsg );
  2595.  
  2596.  SetupMsg.ShowModal;
  2597.  
  2598.  if SetupMsg.ModalResult = mrOK then begin
  2599.   Result:=SaveMessageToStream(SetupMsg.MessageFont,
  2600.                               SetupMsg.MessageSpeed,
  2601.                               SetupMsg.MessageColor,
  2602.                               SetupMsg.MessageMsg);
  2603.  end;
  2604.  SetupMsg.destroy;
  2605.  SetupMsg:=Nil;
  2606. end;
  2607. {------------------------------------------------------------------------}
  2608.  
  2609. Procedure TDBMultiMedia.FreeMsg;
  2610. Begin
  2611.   Picture.Assign(nil);
  2612.   Color:=OldColor;
  2613.   MessageRunning:=False;
  2614. end;
  2615. {------------------------------------------------------------------------}
  2616.  
  2617. Function TDBMultiMedia.Delay(Ms : Integer) : boolean;
  2618. Begin
  2619.  Inc(DelayCounter);
  2620.  if DelayCounter > MS then begin
  2621.   DelayCounter:=0;
  2622.   Result:=true;
  2623.  end else
  2624.   Result:=false;
  2625. end;
  2626. {------------------------------------------------------------------------}
  2627.  
  2628. Procedure TDBMultiMedia.MoveMsg(Var WinMsg : TMessage);
  2629. Begin
  2630.   if Not MessageRunning then exit;
  2631.   if Not Delay(MsgSpeed)then exit;
  2632.   Dec(SMessageLeft,1);
  2633.   Dec(SMessageRight,1);
  2634.   Inc(MmsgCount,1);
  2635.   if SMessageRight < 0 then begin
  2636.     SMessageLeft := ScreenWd;
  2637.     SMessageRight := SMessageLeft + BitWidth;
  2638.   end;
  2639.     with Canvas do
  2640.        Draw(SMessageLeft,SMessageTop,BitMsg);
  2641. end;
  2642. {------------------------------------------------------------------------}
  2643.  
  2644. Procedure TDBMultiMedia.Trigger;
  2645. Begin
  2646.   if SetupMsg <> nil then SetupMsg.Trigger;
  2647.   if (visible) and (enabled) then
  2648.    PostMessage(Handle, WM_Trigger, 0, 0);
  2649. End;
  2650. {------------------------------------------------------------------------}
  2651.  
  2652. Function TDBMultiMedia.SaveMessageToStream(MFont  : Tfont;
  2653.                                            Mspeed : integer;
  2654.                                            MColor : Tcolor;
  2655.                                            MMsg   : String) : Boolean;
  2656. var
  2657.    Stream       :  TMemoryStream;
  2658.    Cursor       :  hCursor;
  2659.    Usize        :  longInt;
  2660.    P            :  Array[0..1602] of char;
  2661. begin
  2662.   Result:=True;
  2663.   if FDataLink.Field is TBlobField then begin
  2664.      If Length(MMsg) < 1 then
  2665.       begin
  2666.         Result:=False;
  2667.         exit;
  2668.        end;
  2669.  
  2670.       Usize:=WriteMessageToStream(MFont, MSpeed, MColor, MMsg, P);
  2671.  
  2672.       If Usize < 1 then
  2673.        begin
  2674.         Result:=False;
  2675.         exit;
  2676.        end;
  2677.  
  2678.       Stream:=TMemoryStream.Create;
  2679.       Stream.Write(P,Usize+1);
  2680.  
  2681.       try
  2682.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  2683.       finally
  2684.         Stream.Free;
  2685.       end;
  2686.      GetInfoAndType;
  2687.    end;
  2688. end;
  2689.  
  2690. {------------------------------------------------------------------------
  2691. Printing Stuff
  2692. ------------------------------------------------------------------------}
  2693.  
  2694. procedure TDBMultiMedia.PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  2695. begin
  2696.  if Picture.Graphic.Empty then exit;
  2697.  
  2698.  if (BFiletype = 'ICO') or (BFiletype = 'WMF') then
  2699.    PrintICOWMF(X, Y, pWidth, pHeight)
  2700.  else
  2701.    PrintBitMap(X, Y, pWidth, pHeight)
  2702. end;
  2703. {---------------------------------------------------------------------}
  2704.  
  2705. procedure TDBMultiMedia.PrintBitMap(X, Y, pWidth, pHeight: Integer);
  2706. var
  2707.   Info     : PBitmapInfo;
  2708.   InfoSize : Integer;
  2709.   Image    : Pointer;
  2710.   ImageSize: Longint;
  2711. begin
  2712.    if (pWidth < 1) or (pHeight < 1) then begin
  2713.       pWidth:=Picture.Bitmap.Width;
  2714.       pHeight:=Picture.Bitmap.Height;
  2715.    end;
  2716.  
  2717.    Printer.Begindoc;
  2718.  
  2719.     with Picture.Bitmap do begin
  2720.       GetDIBSizes(Handle, InfoSize, ImageSize);
  2721.       Info := MemAlloc(InfoSize);
  2722.       try
  2723.         Image := MemAlloc(ImageSize);
  2724.         try
  2725.           GetDIB(Handle, Palette, Info^, Image^);
  2726.           with Info^.bmiHeader do
  2727.            StretchDIBits(Printer.Canvas.Handle, X, Y, pWidth,
  2728.             pHeight, 0, 0, biWidth, biHeight, Image, Info^,
  2729.             DIB_RGB_COLORS, SRCCOPY)
  2730.          finally
  2731.           FreeMem(Image, ImageSize);
  2732.          end;
  2733.       finally
  2734.        FreeMem(Info, InfoSize);
  2735.       end;
  2736.     end;
  2737.     Printer.Enddoc;
  2738.   end;
  2739. {---------------------------------------------------------------------}
  2740.  
  2741. procedure TDBMultiMedia.PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  2742. begin
  2743.    if (pWidth < 1) or (pHeight < 1) then begin
  2744.     pWidth:=Picture.Graphic.Width;
  2745.     pHeight:=Picture.Graphic.Height;
  2746.    end;
  2747.  
  2748.    Printer.Begindoc;
  2749.  
  2750.    Printer.Canvas.StretchDraw(Rect(X, Y, pWidth, pHeight), Picture.Graphic);
  2751.  
  2752.    Printer.Enddoc;
  2753. end;
  2754.  
  2755. {------------------------------------------------------------------------}
  2756.  
  2757. {------------------------------------------------------------------------}
  2758.  
  2759.  
  2760.  
  2761. begin
  2762.  TDBMultiImageCallBack:=nil;
  2763.  TDBMultiMediaCallBack:=nil;
  2764. end.
  2765.  
  2766.  
  2767.